FishMarket 1.0/FishMarket v1.0.iso/fishies/126-150/disk_144/analyticalc/analysources.arc/AnalyNS.Ftn

Text File | 1988-04-10 | 83KB | 3,076 lines

c -h- nextel.fms    Tue Sep  2 10:58:55 1986
    SUBROUTINE NEXTEL (RETVAL,RETTYP,RETCD)
C COPYRIGHT (C) 1983,1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C
C  SCANS LINE(80) FROM NONBLK+1 AND RETURNS THE NEXT ELEMENT.
C  THIS ELEMENT COULD BE A CONSTANT, VALUE OF A VARIABLE, A
C  BINARY FUNCTION CODE, OR A UNARY FUNCTION CODE. UPON RETURN,
C  NONBLK POINTS TO LAST CHARACTER OF NEXT ELEMENT.
C
C  RETCD  =    1  IF OPERAND (VALUE IN RETVAL(100)
C        2  IF OPERATOR (VALUE IN RETTYP)
C        3  NO MORE ELEMENTS
C        4  IF ERROR
C
C  RETVAL  HOLDS VALUE OF OPERAND FOUND (EITHER CONSTANT OR IF
C       A VARIABLE (A-Z,%), THE VALUE OF THAT VARIABLE)
C
C  RETTYP  IS THE TYPE CODE
C NEXTEL CALLS
C
C ERRMSG     PRINTS OUT ERROR MESSAGES
C FLIP       REVERSES THE NON-LEADING ZERO DIGITS IN A VECTOR
C GETNNB     GETS THE NEXT NON-BLANK FROM LINE(80)
C
C NEXTEL IS CALLED BY INPOST
C
C
C    VARIABLE    USE
C    ---------   ----------------------------------
C
C    ALPHA(27)   HOLDS LEGAL VARIABLE NAMES.
C
C    ARROW       '^'
C
C    B10         SWITCH SET WHEN CONSTANT IS NOT OCTAL (MAY BE
C                DECIMAL OR HEX BECAUSE THE DIGIT 8 OR 9 WAS FOUND).
C
C    B16         SWITCH SET WHEN CONSTANT IS HEXADECIMAL BECAUSE
C                DIGIT A, B, C, D, E, OR F WAS FOUND.
C
C    BASE        HOLDS BASE OF CONSTANT.
C
C    CHAR1       HOLDS A SINGLE CHARACTER FROM LINE.
C
C    DEFBAS      THE DEFAULT BASE SPECIFIED.
C
C    DIGITS(16,3) HOLDS ASCII CHARACTERS FOR THE DIGITS OF BASES
C                 8, 10, AND 16.
C
C    DOT          '.'
C
C    EQ           '='
C
C    EXCODE       CODE FOR EXPONENTIATION.
C
C    FCNT         NUMBER OF UNARY FUNCTIONS DEFINED BY VECTOR FUNCT
C
C    FUNCT (NAME,INDXX) HOLDS FUNCTION NAMES.
C
C    FUNVAL(I,J)
C     IF I=1, THE VALUE IS THE NUMBER OF CHARACTERS IN THE J-TH
C             FUNCTION WHOSE NAME IS THE FUNCT(K,J) WHERE K=1,2,3...10
C     IF I=2, THE VALUE IS THE STACK ELEMENT CODE FOR THE J-TH
C             FUNCTION WHOSE NAME IS IN FUNCT(K,J), K=1,2,3...10
C
C
C    I,J,K,L  HOLDS TEMPORARY VALUES
C
C    I1,I2    HOLD VALUE OF DIGITS IN E OR D SPECIFICATION.
C
C    IALPHA   INDEX INTO ALPHA OF THE FIRST NON-BLANK CHARACTER FOUND.
C
C    IHOLD    HOLDS TEMPORARY VALUES
C
C    INT      PICKS UP INTEGER*4 VALUES.
C
C    IPT      POINTER TO ELEMENTS IN LINE(80).
C
C    IPT2     POINTER TO ELEMENTS IN LINE(80).
C
C    LASTOP  USED TO HOLD VALUE OF LAST OPERATOR SO THAT UNARY OPERATORS
C            CAN BE IDENTIFIED IN CASES LIKE A*-B AND A/(-3).
C
C    MINUS   '-'
C
C    OPER(9) HOLDS LEGAL ONE CHARACTER OPERATORS LIKE '+' AND '*'.
C
C    PLUS    '+'
C
C    QUOTE   "'"
C
C    RB      HOLDS NEGATIVE POWERS OF 10.(BASE 10)
C
C    REAL    PICKS UP REAL*8 CONSTANTS.
C
C    RETCD   RETURN CODE:
C              1 IF OPERAND (VALUE IN RETVAL(100))
C              2 IF OPERATOR (VALUE IN RETTYP)
C              3 NO MORE ELEMENTS.
C              4 IF ERROR.
C
C    RETCD2  RETURN CODE WHEN CALLING GETNNB.
C
C    RETPT   INDEXES DIGITS PICKED UP FOR A CONSTANT.
C
C    RETTYP  THE TYPE CODE OF THE RETURNED ELEMENT.
C
C    TYPE    TYPE CODE FOR EACH VARIABLE.
C
C    VBLS    HOLDS VALUE OF VARIABLES.
C
C    VLEN    GIVES LENGTH IN BYTES FOR EACH DATA TYPE.
C
C LASTOP MUST BE SET TO ZERO AT START OF EXPRESSION
C
C
    REAL*8 REAL,RB,ACX,XAC
    INTEGER*4 INT
    EXTERNAL INDX,DFLOAT
    REAL*8 DFLOAT
    InTeGer*4 INDXX
    InTeGer*4 LEVEL,NONBLK,LEND
    InTeGer*4 LASTOP
    InTeGer*4 VIEWSW,BASED,VLEN(9),DEFBAS
    InTeGer*4 TYPE(1,1)
    InTeGer*4 RETCD,RETCD2,RETTYP,EXCODE
    InTeGer*4 B10,B16,RETPT,BASE
    InTeGer*4 FCNT,AHOLD
    InTeGer*4 I,J,K,L,IALPHA,IHOLD,IPT,IPT2,I1,I2
C
    CHARACTER*1 CHAR1,DOT,ARROW,QUOTE,STAR,MINUS,PLUS
    CHARACTER*1 RETVAL(20)
C    REAL*8 RVLF
C    EQUIVALENCE (FVLF,RETVAL(1))
    CHARACTER*1 FUNCT(10,40)
    InTeGer*4   FUNVAL(2,40)
    CHARACTER*1 AVBLS(20,27)
    EQUIVALENCE(XAC,AVBLS(1,27))
    CHARACTER*1 VBLS(8,1,1)
    CHARACTER*1 OPER(9),DIGITS(16,3)
    CHARACTER*1 LINE(80),ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
    CHARACTER*1 FOUR(4),EIGHT(8)
C
    COMMON /V/ TYPE,AVBLS,VBLS,VLEN
    COMMON /DIGV/ DIGITS
    COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
    COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
c    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    COMMON /ERROR/ LASTOP
C
    EQUIVALENCE (REAL,EIGHT),(FOUR,INT)
C
    DATA DOT/'.'/,ARROW/'^'/,QUOTE/''''/,STAR/'*'/
    DATA MINUS/'-'/,PLUS/'+'/
    DATA OPER/'(','-','!','*','/','+','-',')','='/
C
C  NUMBER OF FUNCTIONS
    DATA FCNT/30/
C
    DATA FUNCT/'A','B','S',' ',' ',' ',' ',' ',' ', ' ',
     1             'D','A','B','S',' ',' ',' ',' ',' ',' ',
     2             'I','A','B','S',' ',' ',' ',' ',' ',' ',
     3             'F','L','O','A','T',5*' ','I','F','I','X',6*' ',
     5             'A','I','N','T',6*' ','I','N','T',7*' ',
     7             'I','D','I','N','T',5*' ','E','X','P',7*' ',
     9             'D','E','X','P',6*' ','A','L','O','G','1','0',4*' ',
     2             'D','L','O','G','1','0',4*' ','A','L','O','G',6*' ',
     4             'D','L','O','G',6*' ','S','Q','R','T',6*' ',
     6             'D','S','Q','R','T',5*' ','S','I','N',7*' ',
     8             'D','S','I','N',6*' ','C','O','S',7*' ',
     1             'D','C','O','S',6*' ','T','A','N','H',6*' ',
     2             'D','T','A','N','H',5*' ','A','T','A','N',6*' ',
     3             'D','A','T','A','N',5*' ',
     1             'A','S','I','N',6*' ','D','A','S','I','N',5*' ',
     2             'A','C','O','S',6*' ','D','A','C','O','S',5*' ',
     3             'T','A','N',' ',6*' ','D','T','A','N',106*' '/
    DATA EXCODE/112/
       DATA FUNVAL/3,31,4,31,4,32,5,33,4,34,4,35,3,36,5,36,3,37,4,37,
     1 6,39,6,39,4,38,4,38,4,40,5,40,3,41,4,41,3,42,4,42,4,43,5,43,
     2       4,44,5,44,4,45,5,45,4,46,5,46,3,47,4,47,20*0/
C
10    CONTINUE
    CALL GETNNB(IPT,RETCD2)
    IF (RETCD2.EQ.1) GOTO 50
C
C  NO MORE ELEMENTS
    LASTOP=0
    RETCD=3
    RETURN
C
C
C  INITIALIZE VARIABLES
50    CONTINUE
    B10=0
    B16=0
    RETTYP=0
    RETPT=0
    REAL=0.D0
    RETCD=1
    DEFBAS=BASED
C    RVLF=0.0D0
C COMMENT OUT DO LOOP OVER 20 BYTES FOR SPEED.
C (INSTEAD JUST ZERO 8 BYTES WE WILL LIKELY USE)
    DO 60 I=1,8
C    DO 60 I=1,20
60    RETVAL(I)=0
C
70    CHAR1=LINE(IPT)
    NONBLK=IPT
C
C
C  SEE IF ALPHABETIC OR %
C SHORTCUT IF IT'S A CELL NAME .. GO JUST EVALUATE IT.
C ALSO WORKS FOR ENCODED FUNCT NAMES.
    IF(ICHAR(CHAR1).GE.255)GOTO 12000
C SEPARATE OUT FUNCTION CALLS FOR FASTER EXECUTION...SKIP TRYING FUNCT. NAME
C FIRST AS VARIABLE NAME (WHICH CAN TAKE LONG TIME TO CONVERT BEFORE WE DISCOVER
C IT ISN'T NEEDED...)
C
    IF(ICHAR(CHAR1).GE.230)GOTO 13201
C ADD COUPLE MORE SHORTCUTS... DON'T JUST LOOP TO SEE IF WE HAVE
C AN ALPHA CHARACTER...
    IF(CHAR1.NE.ALPHA(27))GOTO 78
    I=27
    GOTO 10000
78    CONTINUE
    IF(CHAR1.LT.'A'.OR.CHAR1.GT.'Z')GOTO 79
C TRY TO AVOID LOTS OF EXTRA FUNCTION CALLS...
C COMPARE CHARS AS CHARACTER VALUES... SHOULD STILL BE OK.
CCC    IF(ICHAR(CHAR1).LT.ICHAR(ALPHA(1))
CCC     1  .OR.ICHAR(CHAR1).GT.ICHAR(ALPHA(26)))GOTO 79
C USE FACT THAT ASCII CHARACTER CODES ARE IN A CONTINUOUS RANGE
CCC    I=ICHAR(CHAR1)-ICHAR(ALPHA(1))
    I=ICHAR(CHAR1)-65
C 65 IS ASCII VALUE FOR 'A' CHARACTER.
C (HARDCODE FOR SPEED...)
    GOTO 10000
79    CONTINUE
C DELETE 3 LINES FOLLOWING:
C    DO 80 I=1,27
C    IF (CHAR1.EQ.ALPHA(I)) GOTO 10000
C80    CONTINUE
C
C
C  NOT ALPHA SO SEE IF AN OPERATOR
    DO 100 I=1,9
    IF (CHAR1.EQ.OPER(I)) GOTO 20000
100    CONTINUE
C
C
C SEE IF AN OPERAND
C *** EVIDENTLY SHORT LOOP RUNS AS FAST AS A COUPLE DECISIONS AND SOME
C MATH; LEAVE IN.
140    DO 150 I=1,16
    IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
150    CONTINUE
C
C
C
    IF (CHAR1.EQ.DOT) GOTO 40000
C
C
C
    IF (CHAR1.EQ.ARROW) GOTO 300
C
C
C
    IF (CHAR1.EQ.QUOTE) GOTO 200
C
C
C  ADDITIONAL CONSTANT OPERATOR WOULD GO HERE
C
C
C *** ERROR *** ILLEGAL CHARACTER ENCOUNTERED
190    CALL ERRMSG (20)
    GOTO 99000
C
C
C
C
C **************************************
C ****** ASCII CONSTANT SPECIFIED ******
C **************************************
200    CONTINUE
    NONBLK=NONBLK+1
    RETVAL(1)=ICHAR(LINE(NONBLK))
    RETTYP=1
    GOTO 35100
C
C
C
C
C **************************************
C ****** IMMEDIATE BASE SPECIFIED ******
C **************************************
300    CALL GETNNB(IPT,RETCD2)
    IF (RETCD2.EQ.1) GOTO 320
C
C
C *** ERROR *** ILLEGAL BASE SPECIFICATION
310    CALL ERRMSG(19)
    GOTO 99000
C
C
C  IMMEDIATE BASE SPECIFICATION
320    CHAR1=LINE(IPT)
    NONBLK=IPT
    IF (CHAR1.EQ.DIGITS(8,3)) GOTO 360
    IF (CHAR1.NE.DIGITS(1,3)) GOTO 310
C
C
C FIRST DIGIT IS 1 SO IMMEDIATE BASE MIGHT BE 10 OR 16
    CALL GETNNB (IPT,RETCD2)
    IF (RETCD2.EQ.2) GOTO 310
    CHAR1=LINE(IPT)
    NONBLK=IPT
    IF (CHAR1.EQ.DIGITS(10,1)) GOTO 365
    IF (CHAR1.NE.DIGITS(6,1)) GOTO 310
C
C
C IMMEDIATE BASE IS 16
    DEFBAS=16
    GOTO 370
C
C
C IMMEDIATE BASE IS 8
360    DEFBAS=8
    GOTO 370
C
C
C IMMEDIATE BASE IS 10
365    DEFBAS=10
C
C
C
370    CALL GETNNB(IPT,RETCD2)
    IF (RETCD2.EQ.2) GOTO 310
    CHAR1=LINE(IPT)
    NONBLK=IPT
C
C
C GO FIND OUT WHAT NUMBER HAS THAT DEFAULT BASE
    GOTO 140
C
C
C
C
C ****************************************************
C ****** SEARCH TO SEE IF A UNARY FUNCTION NAME ******
C ****************************************************
10000    CONTINUE
    IALPHA=I
    IHOLD=NONBLK
C
C
C SCAN EACH OF THE FUNCTION NAMES.
    DO 10060 I=1,FCNT
C
C K HOLDS NUMBER OF NON-BLANK CHARACTERS IN THE FUNCTION NAME.
    K=FUNVAL(1,I)
    IPT2=IHOLD
    NONBLK=IHOLD
    IF (K.EQ.0) GOTO 10060
C
C
C SCAN EACH LETTER OF THE FUNCTION'S NAME
    DO 10050 J=1,K
    IF (LINE(IPT2).NE.FUNCT(J,I)) GOTO 10060
    IF (J.EQ.K) GOTO 10100
    CALL GETNNB (IPT2,RETCD2)
    IF (RETCD2.EQ.2) GOTO 10060
    NONBLK=IPT2
10050    CONTINUE
    STOP 10050
C
10060    CONTINUE
10070    NONBLK=IHOLD
    GOTO 12000
C
C
C  FUNCTION FOUND (LEAVES NONBLK POINTING AT LAST CHARACTER)
10100    CONTINUE
C
C
C
C
C **********************************
C ****** UNARY FUNCTION FOUND ******
C **********************************
    RETTYP=ICHAR(CHAR(FUNVAL(2,I)))
    LASTOP=RETTYP
    RETCD=2
    GOTO 99099
C
C
C
C
C
C ********************************
C ****** VARIABLE SPECIFIED ******
C ********************************
12000    CONTINUE
C
C
C  IALPHA HOLDS INDEX INTO ALPHA OF NAME
C ******&&&&&& REMOVE BLK OF CODE STARTING HERE...
C    CALL GETNNB (IPT,RETCD2)
C    IF (RETCD2.EQ.2) GOTO 12060
CC
CC
CC MAKE SURE NEXT CHARACTER IS NOT ALPHA
C    DO 12050 I=1,27
C    IF (LINE(IPT).EQ.ALPHA(I)) GOTO 12200
C12050    CONTINUE
C *****&&&&& ...ENDING HERE
C ADD BELOW...
    LLB=IPT
    LRB=LEND
    CALL VARSCN(LINE,LLB,LRB,LSTCHR,ID1,ID2,IVALID)
C    IF(IVALID.EQ.0)GOTO 12200
C    IPT=LSTCHR
    IF(IVALID.NE.0.AND.ID2.LE.1.AND.ID1.GT.60)GOTO 13201
    IF(IVALID.NE.0)GOTO 12201
C NOT VALID VARIABLE. SEE IF A 2 + ARGUMENT FUNCTION...
C
C COME HERE DIRECT FOR FUNCTIONS ENCODED...
13201    CONTINUE
    I=IPT+9
    CALL FNAME(LINE(IPT),I,INDEXF)
    IF(INDEXF.EQ.6.OR.INDEXF.LT.1.OR.INDEXF.GT.26)GOTO 12202
C NOW KNOW THERE IS A FUNCTION THERE, SO HANDLE IT.
    LLAST=LEND-IPT+1
    I=INDX(LINE(IPT),ICHAR(']'))
    IF(I.LE.0.OR.I.GT.LLAST)GOTO 12202
    LRB=I
    LLB=INDX(LINE(IPT),ICHAR('['))
    IF(LLB.LE.0.OR.LLB.GT.LLAST)GOTO 12202
    CALL DOMFCN(LINE(IPT),LLB,LRB,INDEXF,ACX)
    XAC=ACX
    TYPE(1,1)=2
    CALL TYPSET(1,27,TYPE(1,1))
C    TYPE(27,1)=2
    ID1=27
    ID2=1
    LSTCHR=LRB+IPT
C GO AND MERGE AS THOUGH WE JUST GOT A VARIABLE % AND HAD TO
C RETURN ITS VALUE.
    GOTO 12201
C IF NOT VALID FUNCTION REPORT AN ERROR.
12202    GOTO 12200
12201    IPT=LSTCHR
    IF(LSTCHR.LT.LEND)IPT=IPT-1
    NONBLK=IPT
C RESET NONBLK ALST SO WE RESET GETNNB TOO...
C WAS IPT=LSTCHR+1
C IPT POINTS AFTER VARIABLE NAME...
C ENSURE NON ALPHA AFTER VARIABLE NAME
    CALL GETNNB(IPT,RETCD2)
    IF(RETCD2.EQ.2) GOTO 12060
C
C IF THE NEXT CHARACTER IS AN = SIGN DON'T RETURN VALUE
C OF VARIABLE, JUST PUT INDEX INTO VBLS INTO LOWER BYTE
C OF RETVAL.
    IF (LINE(IPT).EQ.EQ) GOTO 12100
C
C
C ************************************************
C ****** RETURN VALUE OF VARIABLE SPECIFIED ******
C ************************************************
12060    CALL TYPGET(ID1,ID2,RETTYP)
C12060    RETTYP=TYPE(ID1,ID2)
C *****&&&&&
C MUST CLAMP TYPES SO EXTENDED VARIABLES CAN'T BE MULT PRCN VRBLS.
    IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12061
    IF (RETTYP.EQ.5)RETTYP=4
    IF (RETTYP.EQ.6)RETTYP=8
    IF (RETTYP.EQ.7)RETTYP=3
12061    CONTINUE
    IF(RETTYP.LE.0)GO TO 12080
    K=VLEN(RETTYP)
    DO 12070 I=1,K
    IF(ID1.LE.27.AND.ID2.EQ.1) GOTO 12068
C TRY AND CALL XVBLGT HERE TO GET VALUE ALL AT ONCE
C TO AVOID MULTIPLE ARBITRATION...
    IF(I.EQ.K)CALL XVBLGT(ID1,ID2,RETVAL)
C    CALL VBLGET(I,ID1,ID2,RETVAL(I))
C    RETVAL(I)=VBLS(I,ID1,ID2)
    GOTO 12070
12068    RETVAL(I)=AVBLS(I,ID1)
12070    CONTINUE
C
12080    LASTOP=RETTYP
    GOTO 99099
C
C
C
C *******************************************************
C ****** VARIABLE SPECIFIED BUT FOLLOWED BY = SIGN ******
C *******************************************************
12100    CONTINUE
C    RETVAL(1)=IALPHA
C    RETTYP=TYPE(IALPHA)
    CALL TYPGET(ID1,ID2,TYPE(1,1))
    CALL RVBOO(RETVAL,ID1,ID2)
C RVBOO JUST STUFFS ID1,ID2 INTO RETVAL ARRAY
C AS 2 INTEGERS.
    RETTYP=TYPE(1,1)
    GOTO 12080
C
C
C
C *** ERROR *** UNIDENTIFIED FUNCTION
12200    CALL ERRMSG(18)
    GOTO 99000
C
C
C
C
C
C **********************
C ****** OPERATOR ******
C **********************
C
C  I IS INDEX INTO OPER TO TELL WHAT OPERATOR IT IS
20000    CONTINUE
    RETCD=2
    IF(I.NE.4)GO TO 20050
C
C
C IF AN ASTERISK IS FOUND THE NEXT CHARACTER MUST BE EXAMINED
C TO SEE IF '**' WAS SPECIFIED FOR EXPONENTIATION.
    CALL GETNNB (IPT,RETCD2)
    IF(RETCD2.NE.1)GO TO 99000
    IF (LINE(IPT).NE.STAR) GOTO 20050
C
C
C '**' SPECIFIED (EXPONENTIATION)
    RETTYP=EXCODE
    NONBLK=IPT
    GO TO 12080
C
C
C
C  SET DEFAULT RETTYP FOR OPERATORS
20050    RETTYP=109+I
C
C
C  CHECK OUT POSSIBLE UNARY OPERATOR "-"
    IF (RETTYP.NE.111) GOTO 20080
C
C
C IF A MINUS IS ENCOUNTERED AND THERE WAS NO PREVIOUS ELEMENT OR
C IF PREVIOUS ELEMENT WAS AN OPERATOR OR = SIGN THEN OPERATOR
C IS UNARY.
    IF (LASTOP.EQ.0.OR.(LASTOP.GE.110.AND.LASTOP.LE.116).OR.
     ;      LASTOP.EQ.200) GOTO 20090
C
C
C  BINARY SUBTRACTION OPERATOR
    RETTYP=116
    GOTO 12080
C
C
C
C SEE IF A '+' SIGN
20080    IF(RETTYP.NE.115)GO TO 20085
C
C
C DETERMINE IF IT IS A UNARY PLUS
    IF(LASTOP.NE.0.AND.LASTOP.LE.100)GO TO 20085
C
C
C SEE IF LAST OPERATOR WAS ')'
    IF(LASTOP.EQ.117)GO TO 20085
C
C
C UNARY '+' FOUND.
    RETCD=1
    GO TO 10
C
C
C
C RESET LASTOP TO 0 IF LEFT PARENTHESIS IS FOUND (CODE 110)
C IF RETTYP IS FOR =, SET TO PROPER CODE
20085    IF(RETTYP.EQ.110)GO TO 20090
    IF(RETTYP.EQ.118)RETTYP=200
    GO TO 12080
C
C
C UNARY -
20090    CONTINUE
    GOTO 99097
C
C
C
C
C
C
C *************************
C ****** NON-DECIMAL ******
C *************************
C
30000    RETPT=RETPT+1
    IF (RETPT.LE.19) GOTO 30020
C
C
C *** ERROR *** MULTIPLE PRECISION IS LIMITED TO 19 DIGITS
C (ACTUALLY, NO LONGER PRESENT...)
    CALL ERRMSG(22)
    GOTO 99000
C
C
C  I HOLDS INDEX INTO DIGITS THAT WAS A MATCH.
C  SEE IF VALUE OF DIGIT IMPLIES A HIGHER BASE.
30020    IF (I.NE.16) GOTO 30030
    I=0
    GOTO 30050
30030    IF (I.EQ.8.OR.I.EQ.9) B10=1
    IF(I.GT.9) B16=1
30050    RETVAL(RETPT)=CHAR(I)
C
C
C GET NEXT CHARACTER
    CALL GETNNB (IPT,RETCD2)
    IF (RETCD2.NE.1) GOTO 30100
    NONBLK=IPT
    CHAR1=LINE(IPT)
    DO 30070 I=1,16
    IF (CHAR1.EQ.DIGITS(I,3)) GOTO 30000
30070    CONTINUE
    IF (CHAR1.EQ.DOT) GOTO 40000
    NONBLK=NONBLK-1
30100    CONTINUE
C
    IF (DEFBAS.EQ.16.OR.B16.EQ.1) GOTO 30200
    IF (DEFBAS.EQ.10.OR.B10.EQ.1) GOTO 30300
C
c add code here to check for non -calc mode and goto 40000 if so
c if defbas.ne.8 and if we're working on a floating number
C
C *****************************
C ****** BASE 8 CONSTANT ******
C *****************************
    BASE=8
C
C
C IF MORE THAN 10 DIGITS IT IS MULTIPLE PRECISION
    IF (RETPT.GT.10) GOTO 30170
    RETTYP=8
C
C
C  CONVERT TO OCTAL, HEX OR INTEGER
30110    INT=0
30130    DO 30132 L=1,7
    IF (ICHAR(RETVAL(L)).NE.0) GOTO 30140
30132    CONTINUE
30140    DO 30150 I=L,RETPT
    INT=INT*BASE+ICHAR(RETVAL(I))
    RETVAL(I)=0
30150    CONTINUE
    RETVAL(20)=0
30155    DO 30160 I=1,4
30160    RETVAL(I)=FOUR(I)
    GOTO 35100
C
C
C ************************************************
C ****** MULTIPLE PRECISION BASE 8 CONSTANT ******
C ************************************************
30170    RETTYP=6
30180    CALL FLIP (RETVAL,8,RETPT)
c was 20 above, not 8 but we shortened stack arrays so shorten this
    GOTO 35100
C
C
C
C *********************
C ****** BASE 16 ******
C *********************
30200    BASE=16
C
C
C IF MORE THAN 7 DIGITS IT IS MULTIPLE PRECISION.
    IF (RETPT.GT.7) GOTO 30270
C
C
C
C  HEXADECIMAL
    RETTYP=3
    GOTO 30110
C
C
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 16 ******
C ****************************************
30270    RETTYP=7
    GOTO 30180
C
C
C *********************
C ****** BASE 10 ******
C *********************
30300    BASE=10
C
C
C IF MORE THAN 9 DIGITS IT IS MULTIPLE PRECISION.
    IF (RETPT.GT.9) GOTO 30370
C
C
C  INTEGER
    RETTYP=4
    GOTO 30110
C
C
C ****************************************
C ****** MULTIPLE PRECISION BASE 10 ******
C ****************************************
30370    RETTYP=5
    GOTO 30180
C
C
C
C
C
C SET LASTOP AND EXIT
35100    LASTOP=RETTYP
    GOTO 99099
C
C
C *****************************
C ****** REAL OR DECIMAL ******
C *****************************
40000    IF (B16.NE.1) GOTO 40020
C
C
C *** ERROR ***  '.' MAY ONLY BE USED WITH BASE 10
    CALL ERRMSG(21)
    GOTO 99000
C
C
C
40020    IF (RETPT.EQ.0) GOTO 40200
C
C
C IGNORE LEADING ZEROES
    DO 40022 L=1,19
    IF (ICHAR(RETVAL(L)).NE.0) GOTO 40030
40022    CONTINUE
C
C IF ALL ZEROES THE LAST ONE COUNTS!
    L=19
C
C
C CONVERT TO A REAL*8 NUMBER
40030    CONTINUE
    REAL=0.D0
    DO 40060 I=L,RETPT
    REAL=REAL*10.D0+ICHAR(RETVAL(I))
    RETVAL(I)=0
40060    CONTINUE
C
C
C  PICK UP FRACTIONAL PART OF REAL (DECIMAL)
40200    CONTINUE
    RB=1.0D0
    RETTYP=2
40205    CALL GETNNB (IPT,RETCD2)
    IF (RETCD2.EQ.1) GOTO 40300
C
C IF NO MORE, YOU GOT IT ALL SO GO PLACE VALUE IN RETVAL.
    GOTO 40537
C
C
C
40300    NONBLK=IPT
    CHAR1=LINE(IPT)
    DO 40320 I=1,10
    IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40330
40320    CONTINUE
    GOTO 40350
40330    IF (I.EQ.10) I=0
    RB=0.1D0*RB
    REAL=REAL+DFLOAT(I)*RB
    GOTO 40205
C
C
C CHECK TO SEE IF E OR D EXPONENT SPECIFICATION IS USED.
40350    IF (CHAR1.EQ.DIGITS(13,3).OR.CHAR1.EQ.DIGITS(14,3)) GOTO 40360
    NONBLK=NONBLK-1
    GO TO 40537
C
C
C *********************************************
C ****** E AND D EXPONENT SPECIFICATIONS ******
C *********************************************
40360    CONTINUE
    CALL GETNNB(IPT,RETCD2)
    IF (RETCD2.EQ.1) GOTO 40370
C
C
C *** ERROR *** ILLEGAL REAL EXPONENT FIELD SPECIFIED
40365    CALL ERRMSG (24)
    GOTO 99000
C
C
40370    CHAR1=LINE(IPT)
    IF (CHAR1.EQ.MINUS) GOTO 40380
    RB=10.D0
    IF (CHAR1.NE.PLUS) GOTO 40400
    GOTO 40390
40380    RB=0.1D0
C
C
C
40390    NONBLK=IPT
    CALL GETNNB (IPT,RETCD2)
40400    IF (RETCD2.GE.2) GOTO 40365
    NONBLK=IPT
    CHAR1=LINE(IPT)
    DO 40450 I=1,10
    IF (CHAR1.EQ.DIGITS(I,1)) GOTO 40480
40450    CONTINUE
    GOTO 40365
40480    IF (I.EQ.10) I=0
C
C
C I1 HOLDS 1ST DIGIT OF EXPONENT SPECIFICATION
    I1=I
    CALL GETNNB (IPT,RETCD2)
    IF (RETCD2.GE.2) GOTO 40550
    CHAR1=LINE(IPT)
    NONBLK=IPT
    DO 40500 I=1,10
    IF(CHAR1.EQ.DIGITS(I,1)) GO TO 40520
40500    CONTINUE
    NONBLK=NONBLK-1
    GOTO 40550
C
C
C I2 HOLDS SECOND DIGIT OF EXPONENT SPECIFICATION.
40520    IF (I.EQ.10) I=0
    I2=I
C
C
40530    RETTYP=9
    REAL=REAL*RB**(I1*10+I2)
C
C
C
C ***************************************************
C ****** COPY REAL*8 INTO RETURN VECTOR RETVAL ******
C ***************************************************
40537    DO 40540 I=1,8
40540    RETVAL(I)=EIGHT(I)
    GOTO 35100
C
C
C
40550    I2=I1
    I1=0
    GOTO 40530
C
C
C
C ********************************
C ******* ERROR PROCESSING *******
C ********************************
99000    CONTINUE
    IV=LEND-NONBLK+1
    CALL VWRT(LINE(NONBLK),IV)
C    WRITE (0,99010) (LINE(I),I=NONBLK,LEND)
C99010    FORMAT (1X,80(A1,\))
    RETCD=4
99097    LASTOP=0
99099    RETURN
    END
c -h- pget.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE PGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
    CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
    COMMON/NMSH/NMSH
    REAL*8 XVBLS(1,1)
    INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 IOLVL
    INTEGER*4 JVBLS(2,1,1)
CCC    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    DIMENSION FORM(128),FVLD(1,1)
    CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2

C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
    CHARACTER*1 LETA
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    InTeGer*4 LLCMD,LLDSP
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
    InTeGer*4 TYPE(1,1),VLEN(9)
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
    REAL*8 XAC,ZAC
    EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
    REAL*8 XXAC,XYAC
    EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    CHARACTER*1 ARGSTR(52,4)
CCC    COMMON/ARGSTR/ARGSTR
C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
    EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
    INTEGER*4 IIRO,IICO,INUMEM
C NEED SOME BIG VARIABLES FOR SAVING THE MAPPINGS
    EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC    COMMON/KLVL/KLVL
    CHARACTER*1 DEFVB(12)
    COMMON/DEFVBX/DEFVB
CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
    InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
    REAL*8 DVS(20,75)
    INTEGER*4 LDVS(2,20,75)
    EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
    CHARACTER*76 CFORM
    EQUIVALENCE(CFORM(1:1),FORM(1))
    COMMON /FVLDC/FVLD
C    CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
    COMMON/DSPCMN/DVS,CWIDS
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC    InTeGer*4 ICREF,IRREF
CCC    COMMON/MIRROR/ICREF,IRREF
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
    ICODE=1
    CLOSE(4)
7954    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
C ASK FOR FILE NAME
    CALL VWRT('Enter Filename>',15)
    III=IOLVL
C    IF(III.EQ.5)III=0
    READ(III,7953,END=510,ERR=510)FORM2
c7952    FORMAT(' Enter filename>\')
7953    FORMAT(128A1)
    DO 6940 II=1,128
    ILN=129-II
    IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
    FORM2(ILN)=0
6940    CONTINUE
6941    CONTINUE
C ILN IS LENGTH OFLINE NOW.
    ILN=MIN0(ILN,127)
    FORM2(ILN+1)=0
    CALL WASSIG(4,FORM2)
C NOW ENCODE COL WIDTHS AND ICREF/IRREF
C SO SAVE/RESTORE OF EXTENDED SHEETS DOESN'T GET
C MESSED UP.
    WRITE(CFORM(1:76),8850,ERR=8851)ICREF,IRREF,(CWIDS(III),
     1  III=1,20),DRWV,DCLV
8850    FORMAT(24I3)
    DO 8855 III=1,80
    II=ICHAR(NMSH(III))
    IF(II.LT.32)II=32
8855    NMSH(III)=CHAR(II)
8851    CONTINUE
    WRITE(4,6951)NMSH,(FORM(II),II=1,76)
6951    FORMAT(80A1,76A1)
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter max. displ down to save or 0 for all>',43)
    III=IOLVL
C    IF(III.EQ.5)III=0
    READ(III,7978,END=510,ERR=510)LDXM
6950    FORMAT(80A1)
7978    FORMAT(I7)
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter max. displcmt right to save or 0 for all>',47)
    III=IOLVL
C    IF(III.EQ.5)III=0
    READ(III,7978,END=510,ERR=510)MDXM
    IF(MDXM.LE.0)MDXM=12000
    IF(LDXM.LE.0)LDXM=12000
C 12000 IS "AN ARBITRARILY LARGE NUMBER TO ASSURE THAT ALL VALID
C RANGES ARE SAVED". IT MUST BE SMALL ENOUGH TO ASSURE WE DON'T OVERFLOW AN
C INTEGER THOUGH.
    IF(CMDLIN(2).NE.'P'.and.CMDLIN(2).GT.' ')GOTO 7950
C TREAT "P" BY ITSELF AS A SAVE PP TYPE COMMAND (PUT PHYS)
    DO 7951 ICO=PCOL,301
    DO 7951 IRO=PROW,60
C GO DOWN AND RIGHT ONLY. ALLOW MIXING THIS WAY.
C    IRX=(ICO-1)*60+IRO
    CALL REFLEC(ICO,IRO,IRX)
    IDRO=IRO-PROW+1
    IDCL=ICO-PCOL+1
    IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7951
C FORM DISPLACEMENT LOCATORS
    CALL FVLDGT(IRO,ICO,FVLD(1,1))
    IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7951
    CALL WRKFIL(IRX,FORM,0)
    CALL CE2A(FORM,FORM2)
    IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
    IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
    CALL TYPGET(IRO,ICO,TYPE(1,1))
    IF(CMDLIN(3).NE.'N')GOTO 5402
    IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5402
C ALWAYS WRITE TEXT OUT EVEN IF SAVING NUMERICALLY
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
C INTERNAL PROC TO PRINT NUMERIC VALUES AT 6400
    LETR='P'
    ASSIGN 5405 TO INUMEM
C    GOTO 6400
6400    CONTINUE
C ASSUME LETR IS SET TO GOOD PREFIX LETTER ASCII VALUE
    CALL XVBLGT(IRO,ICO,XVBLS(1,1))
    IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5403)LETR,IDRO,IDCL,
     1  JVBLS(1,1,1)
5403    FORMAT(1A1,I5,',',I5,',',I15)
    IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5404)LETR,IDRO,IDCL,
     1  XVBLS(1,1)
5404    FORMAT(1A1,I5,',',I5,',',D30.19)
    GOTO INUMEM,(5405,6406)
5402    CONTINUE
C FIND END OF TEXT IN ARRAY
    DO 4330 IV=2,110
    IVVV=113-IV
    IF(ICHAR(FORM2(IVVV)).GT.32)GOTO 4331
4330    CONTINUE
4331    CONTINUE
C SAVE ON PPX IN EFFICIENT FORM.
C DON'T WRITE OUT TRAILING NULLS.
C ENSURE FORMAT HAS NO NULLS IN IT.
    DO 358 IV=120,128
358    IF(ICHAR(FORM2(IV)).LT.32)FORM2(IV)=Char(32)
    IF(CMDLIN(3).EQ.'F')GOTO 6404
C PPF WILL SAVE FORMULAS ONLY
C PPA WILL SAVE FORMULAS AND VALUES (AS WILL PPc WHERE c IS
C ANY CHARACTER EXCEPT N.
    LETR='p'
C FLAG NUMERIC SAVE VIA LOWERCASE P HERE
    ASSIGN 6406 TO INUMEM
C GO WRITE FIRST LINE NUMERICALLY
    GOTO 6400
6406    CONTINUE
C NOW HAVE NUMERIC LINE WRITTEN. WRITE THE SECOND LINE OF THE
C GROUP TO, SO AS NOT TO CONFUSE GRAPHICS PROGRAMS AND THE
C LIKE.
    III=JCHAR(FORM2(119))
    WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6404    CONTINUE
C NOW WRITE OUT FORMULA RECORD.
    WRITE(4,7955)IDRO,IDCL,(FORM2(IV),IV=1,IVVV)
5405    CONTINUE
C DUMP TO SERIAL FILE IN OUR OWN FORMAT, BUT ALL IN ASCII.
7955    FORMAT('P',I5,',',I5,',',128A1)
C NOTE LONG RECORDS.
    III=JCHAR(FORM2(119))
    WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7956    FORMAT(I3,',',9A1,',',I5)
7951    CONTINUE
2751    CONTINUE
C
C NOW SAVE NRDSP AND NCDSP MAPPINGS TOO
C ONLY SAVE MAPPINGS IF 4TH COMMAND CHARACTER IS "M".
C ... THEY TAKE A LOT OF ROOM.
    IF (CMDLIN(4).NE.'M') GOTO 6541
    DO 6540 IRO=DROW,20
    DO 6540 ICO=DCOL,75
    IIRO=64000
    IICO=IIRO
    IIRO=IIRO+IRO
    IICO=IICO+ICO
C NOTE WE MAKE THESE NUMBERS LARGE SO GRAPHING PROGRAMS WON'T TRY
C TO READ THEM.
6955    FORMAT('M',I5,',',I5,',',2I7)
    WRITE(4,6955,ERR=6541)IIRO,IICO,NRDSP(IRO,ICO),
     1  NCDSP(IRO,ICO)
C WRITE A SPECIAL RECORD, FLAGGED BY 'M', TO SAVE A MAPPING CELL
C NEED A 2ND RECORD TOO; JUST SEND LAST ONE AGAIN.
    WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
6540    CONTINUE
6541    CONTINUE
    CLOSE(4)
    GOTO 9990
7950    IF(CMDLIN(2).NE.'D')GOTO 9990
    DO 7957 ICO=DCOL,75
    DO 7957 IRO=DROW,20
    IDRO=IRO-DROW+1
    IDCL=ICO-DCOL+1
    IF(IDRO.GT.LDXM.OR.IDCL.GT.MDXM)GOTO 7957
    NR=NRDSP(IRO,ICO)
    NC=NCDSP(IRO,ICO)
C    IRX=(NC-1)*60+NR
    CALL REFLEC(NC,NR,IRX)
    CALL FVLDGT(NR,NC,FVLD(1,1))
    IF(ICHAR(FVLD(1,1)).EQ.0)GOTO 7957
    CALL WRKFIL(IRX,FORM,0)
    CALL CE2A(FORM,FORM2)
    IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
    IF(ICHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
    IF(CMDLIN(3).NE.'N')GOTO 5412
C EMIT NUMBERS, NOT FORMATS **** CHECK 4 OR 2, ASSUME 4=INTEGER
    IF(JCHAR(FVLD(1,1)).LT.0)GOTO 5412
C WRITE LABELS EVEN IF NUMERIC SAVE
    CALL TYPGET(NR,NC,TYPE(1,1))
    CALL XVBLGT(NR,NC,XVBLS(1,1))
    IF(IABS(TYPE(1,1)).EQ.4)WRITE(4,5413)IDRO,IDCL,JVBLS(1,1,1)
5413    FORMAT('P',I5,',',I5,',',I15)
    IF(IABS(TYPE(1,1)).NE.4)WRITE(4,5414)IDRO,IDCL,XVBLS(1,1)
5414    FORMAT('P',I5,',',I5,',',D30.19)
    GOTO 5415
5412    CONTINUE
    WRITE(4,7958)IDRO,IDCL,(FORM2(IV),IV=1,110)
5415    CONTINUE
7958    FORMAT('D',I5,',',I5,',',128A1)
    DO 359 IV=120,128
359    IF(FORM2(IV).LT.' ')FORM2(IV)=Char(32)
    III=JCHAR(FORM2(119))
    WRITE(4,7956)III,(FORM2(IV),IV=120,128),TYPE(1,1)
7957    CONTINUE
C ALLOW SAVE AS NEEDED OF MAPPING
    GOTO 2751
C    CLOSE(4)
9990    RETURN
510    CONTINUE
    IRTN=1
    CLOSE(IOLVL)
    CLOSE(11)
    OPEN(11,FILE='CON:0/0/100/100/Analy Command')
    RETURN
    END
c -h- pgget.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE PGGET(CMDLIN,ICODE,IRTN)
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
    CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
    COMMON/NMSH/NMSH
    REAL*8 XVBLS(1,1)
    INTEGER KPYBAK
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 IOLVL
    INTEGER*4 JVBLS(2,1,1)
    REAL*8 R8WK
CCC    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    DIMENSION FORM(128),FVLD(1,1)
    INTEGER*4 IRRW,ICCL
C USE BIG NUMBERS SO WE CAN SUBTRACT 64000 AND STILL NOT GET WRAPAROUND.
C (FOR SAVE/RESTORE OF MAP)
    CHARACTER*76 CFORM
    CHARACTER*35 CFORM2
    EQUIVALENCE(CFORM2(1:1),FORM2(1))
    EQUIVALENCE(CFORM(1:1),FORM(1))
    InTeGer*4 NDUM(24)
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC    COMMON/MIRROR/ICREF,IRREF
    CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    InTeGer*4 LLCMD,LLDSP
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    EXTERNAL INDX
    COMMON/D2R/NRDSP,NCDSP
    InTeGer*4 TYPE(1,1),VLEN(9)
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
    REAL*8 XAC,ZAC
    EQUIVALENCE(XAC,AVBLS(1,27)),(ZAC,AVBLS(1,26))
    REAL*8 XXAC,XYAC
    EQUIVALENCE(XXAC,AVBLS(1,24)),(XYAC,AVBLS(1,25))
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    CHARACTER*1 ARGSTR(52,4)
CCC    COMMON/ARGSTR/ARGSTR
C    EQUIVALENCE(ARGSTR(1,1),VBLS(1,1,1))
C USE VBLS ENTRIES THAT WOULD CORRESPOND TO THE UNUSED SPACE
C IN VBLS ARRAY FOR ACCUMULATORS A-Z TO HOLD UP TO 4 ARGUMENTS
C FROM A COMMAND < WHICH READS IN SPACE-DELIMITED ARGUMENTS.
C THIS WILL ALLOW INTERACTIVE ENTRY OF DATA AND AUTO
C SUBSTITUTION OF ARGUMENTS VIA THE EDit COMMAND.
    EQUIVALENCE(XVBLS(1,1),VBLS(1,1,1))
    EQUIVALENCE(JVBLS(1,1,1),XVBLS(1,1))
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
CCC    COMMON/KLVL/KLVL
    CHARACTER*1 DEFVB(12)
    COMMON/DEFVBX/DEFVB
CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
C
C DISPLAY ARRAY WILL KEEP A COPY OF VARIABLES DISPLAYED AND FORMATS
C USED LOCALLY WHICH DISPLAY ROUTINE CAN USE TO SEE WHAT ACTUALLY
C NEEDS TO BE REFRESHED ON SCREEN. DRWV AND DCLV ARE COLS, ROWS OF
C DISPLAY ACTUALLY USED FOR SCREEN.
    InTeGer*4 CWIDS(20)
C CWIDS IS WIDTHS IN CHARACTERS OF COLUMNS ON DISPLAY. NOTE THAT BECAUSE
C OF PECULIAR INVERSION WHICH I AM TOO LAZY TO CORRECT IT IS DIMENSIONED
C AS 20 NOT 75.
    REAL*8 DVS(20,75)
    INTEGER*4 LDVS(2,20,75)
    EQUIVALENCE(LDVS(1,1,1),DVS(1,1))
    COMMON /FVLDC/FVLD
CCC    InTeGer*4 NCEL,NXINI
CCC    COMMON/NCEL/NCEL,NXINI
C    CHARACTER*1 DFMTS(10,20,75)
C 10 CHARACTERS PER ENTRY.
    COMMON/DSPCMN/DVS,CWIDS
C
c7952    FORMAT(' Enter filename>\')
7953    FORMAT(128A1)
6950    FORMAT(80A1)
7978    FORMAT(I7)
7956    FORMAT(I3,1X,9A1,1X,I5)
    CLOSE(4)
7960    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
C GET FILE NAME
    call Vwrt('Enter Filename>',15)
    III=IOLVL
C    IF(III.EQ.5)III=0
    READ(III,7953,END=510,ERR=510)FORM2
    DO 6940 II=1,128
    ILN=129-II
    IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
    FORM2(ILN)=Char(0)
6940    CONTINUE
6941    CONTINUE
C ILN IS LENGTH OFLINE NOW.
    ILN=MIN0(127,ILN)
    FORM2(ILN+1)=Char(0)
C SPECIAL "FAST READ" MODE TO SET UP DATA AREAS ON GETTING OLD SHEETS...
    NXINI=1
    LDXM=INDX(FORM2,ICHAR('/'))
C IF FILE IS FILENAME/M WE WON'T DO IT FAST...
    IF(LDXM.LE.0.OR.LDXM.GE.ILN)GOTO 8400
    FORM2(LDXM)=Char(0)
C TERMINATE AFTER THE / AND SET NXINI TO 0 AGAIN
    NXINI=0
8400    CONTINUE
    CALL RASSIG(4,FORM2)
    READ(4,6951,END=7964,ERR=7964)NMSH,FORM
6951    FORMAT(80A1,76A1,56A1)
6952    FORMAT(24I3)
C TRY TO DECODE ICREF,IRREF, CWIDS, AND DRWV,DCLV
    READ(CFORM(1:76),6952,ERR=6953)NDUM
C IF HERE, THE READ WAS OK (APPARENTLY)
C FILL IN DEFAULTS IF NOTHING BUT ZEROES REALLY WAS SEEN
C (OR JUST ALL SPACES)
    ICREF=NDUM(1)
    IF(ICREF.LE.0.OR.ICREF.GT.60)ICREF=10
    IRREF=NDUM(2)
    IF(IRREF.LE.0.OR.IRREF.GT.300)IRREF=50
C SET UP CWIDS BUT DEFAULT TO 10 IF NO REAL INFO THERE
    DO 6954 III=1,20
    IIVV=NDUM(III+2)
    IF(IIVV.LT.1.OR.IIVV.GT.100)IIVV=10
    CWIDS(III)=IIVV
6954    CONTINUE
C RESTORE NUMBER ROWS AND COLS BEING DISPLAYED
C NOTE WE DO NOT RESTORE THE COMPLETE DISPLAY
C MAPPING; JUST THE WIDTHS AND NUMBERS OF DISPLAY
C COLUMNS, AND WE RESTORE THE EXTENDED MAP SO THAT
C SAVED SHEETS WILL NORMALLY GET BACK THE SAME EXTENDED
C ADDRESSING THAT HAD BEEN SET UP.
    DRWV=NDUM(23)
    IF(DRWV.LT.1.OR.DRWV.GT.20)DRWV=7
    DCLV=NDUM(24)
    IF(DCLV.LT.1.OR.DCLV.GT.75)DCLV=20
6953    CONTINUE
C ADD ABILITY TO SPECIFY MAX DISPL. TO SAVE
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter max. displc. down to restore or 0 for all>',48)
    III=IOLVL
C    IF(III.EQ.5)III=0
    READ(III,7978,END=510,ERR=510)MDXM
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter max. displc. right to restore or 0 for all>',
     1  49)
    READ(III,7978,END=510,ERR=510)LDXM
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter min. displ. down (1 or more)>',35)
    READ(III,7978,END=510,ERR=510)MMDXM
    CALL UVT100(1,LLCMD,1)
    CALL UVT100(12,2,0)
    CALL VWRT('Enter min displ. right (1 or more)>',35)
    READ(III,7978,END=510,ERR=510)LLDXM
    IF(MDXM.LE.0)MDXM=12000
    LLDXM=MAX0(1,LLDXM)
    MMDXM=MAX0(1,MMDXM)
    IF(LDXM.LE.0)LDXM=12000
    IF(CMDLIN(4).EQ.'+'.OR.CMDLIN(4).EQ.'-')RCFGX=1
C ENTER RECALC MANUAL MODE IF ADDING NUMBERS OR SUBT.
C FROM SAVED SHEET
C 12000 IS, AS ABOVE, JUST A "BIG" NUMBER.
7961    CONTINUE
    READ(4,7962,END=7964,ERR=7964)LET1,IRRW,ICCL,(FORM2(IV),
     1  IV=1,110)
7962    FORMAT(A1,I5,1X,I5,1X,128A1)
    DO 4497 IV=1,110
    IVV=111-IV
    IF(FORM2(IVV).GT.' ')GOTO 4496
    FORM2(IVV)=Char(0)
4497    CONTINUE
4496    CONTINUE
C ABOVE LOOP ENSURES THAT EXTRA PARTS OF BUFFER NOT IN SAVE FILE ARE
C ZEROED ON READIN.
    READ(4,7956,END=7964,ERR=7964)III,(FORM2(IV),IV=120,128),
     1  KKTYP
    FORM2(119)=Char(III)
    IF(LET1.EQ.'M')GOTO 6500
C M CODE MEANS WE'RE READING THE DISPLAY-TO-PHYSICAL MAP.
C GO HANDLE IT SPECIALLY, THEN RETURN. FLAGS RECORDS BY
C ADDING 64000 TO ROW AND COL NUMBERS TO AVOID GETTING
C GRAPHICS PROGRAMS MESSED UP.
C  NOTE THAT SAVING THE MAP WAS OPTIONAL AND IS NOT THE
C DO-NOTHING DEFAULT.
    IF(ICHAR(FORM2(119)).EQ.2)FORM2(119)=Char(3)
    IF(JCHAR(FORM2(119)).EQ.-2)FORM2(119)=Char(253)
    IF(IRRW.LE.0.OR.ICCL.LE.0)GOTO 9990
    IF(IRRW.GT.LDXM.OR.ICCL.GT.MDXM)GOTO 7961
    IF(IRRW.LT.LLDXM.OR.ICCL.LT.MMDXM) GOTO 7961
C PRODUCE NEW ADDRESSES IN PHYSICAL SHEET USING SAVED FILE'S ONES
C AND CURSOR LOCATION (SINCE WE SAVE/RESTORE RELATIVE TO CURSOR).
C THIS PROVIDES A SHEET PARTIAL SAVE / MERGE CAPABILITY.
    NR=IRRW+PROW-LLDXM
    NC=ICCL+PCOL-MMDXM
    IF(CMDLIN(2).NE.'D'.AND.LET1.NE.68)GOTO 7963
    IF(CMDLIN(2).EQ.'P')GOTO 7963
C GET DISPLAY VERSION...
    LRR=IRRW+DROW-LLDXM
    LCC=ICCL+DCOL-MMDXM
    LRR=MAX0(1,LRR)
    LCC=MAX0(1,LCC)
    IF(LRR.GT.DRWV.OR.LCC.GT.DCLV)GOTO 7961
    NR=NRDSP(LRR,LCC)
    NC=NCDSP(LRR,LCC)
7963    CONTINUE
C LET1='p'WILL COME HERE TOO. HANDLE IT SINCE IT'S NUMERIC STUFF.
C    IRX=(NC-1)*60+NR
    CALL REFLEC(NC,NR,IRX)
    IF(NR.EQ.0.OR.NC.EQ.0)GOTO 7961
    FORM2(118)=CHAR(15)
    DO 7113 IVV=1,128
7113    FORM(IVV)=FORM2(IVV)
    INRW=PROW
    INCL=PCOL
    JOUTR=1
    JOUTC=2
C A1 = OUT LOCATION FOR INPUT CELL NAMES
    JRTR=1
    JRTC=1
    IF(CMDLIN(3).EQ.'R')CALL RELVBL(FORM,FORM2,JOUTR,JOUTC,
     1  INRW,INCL,JRTR,JRTC)
C ALLOW RELOCATION ON LOADING SAVED SHEET IF DESIRED.
    CALL FVLDST(NR,NC,FORM2(119))
C    FVLD(NR,NC)=FORM2(119)
    CALL TYPSET(NR,NC,KKTYP)
C    TYPE(NR,NC)=KKTYP
    CALL CA2E(FORM2,FORM)
    IF(LET1.NE.'p')CALL WRKFIL(IRX,FORM,1)
C    WRITE(7'IRX)FORM2
    IF(LET1.NE.'p')GOTO 7961
C HAVE LOWERCASE 'p' NOW AS NUMERIC SAVE FLAG FOR THIS RECORD.
    READ(CFORM2(1:35),6408,ERR=7961)XVBLS(1,1)
6408    FORMAT(BN,D30.19)
    CALL XVBLGT(NR,NC,R8WK)
    IF(CMDLIN(4).EQ.'+')XVBLS(1,1)=XVBLS(1,1)+R8WK
    IF(CMDLIN(4).EQ.'-')XVBLS(1,1)=R8WK-XVBLS(1,1)
C IMPLEMENT ADDING AND SUBTRACTING SAVED SHEETS FROM CURRENT.
C GOES TO RECALC MANUAL MODE SINCE RECALC WOULD MESS UP
C VALUES; FORMULAS GET UPDATED FROM LAST-READ SHEET NORMALLY.
    CALL XVBLST(NR,NC,XVBLS(1,1))
    GOTO 7961
6500    CONTINUE
C HERE READ MAPPINGS
    IRRW=IRRW-64000
    ICCL=ICCL-64000
C RESTORE OFFSETS TO NORMAL RANGE
    READ(CFORM2(1:35),6501,ERR=7961)II,III
6501    FORMAT(2I7)
    NRDSP(IRRW,ICCL)=II
    NCDSP(IRRW,ICCL)=III
C GO BACK FOR MORE. INEFFICIENT STORAGE OF MAP BUT IT'S COMPACT
C CODE...
    GOTO 7961
7964    CONTINUE
    CLOSE(4)
9990    NXINI=0
    RETURN
510    CONTINUE
    IRTN=1
    NXINI=0
    CLOSE(IOLVL)
    CLOSE(11)
    OPEN(5,FILE='CON:0/0/100/100/Analy Command')
    RETURN
    END
c -h- pmtx2.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
    CHARACTER*1 LINE(80)
    CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)
C GET LOC OF MATRIX A (MUST BE SQUARE)
    IBGN=LSTCHR+1
    IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
    IF(LINE(LSTCHR).NE.',')GOTO 300
    CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
     1  IDYB,RETCD)
C GET LOC OF MATRIX X (RESULT).
    IBGN=LSTCHR+1
    IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
    IF(LINE(LSTCHR).NE.',')GOTO 300
    CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
     1  IDCB,RETCD)
    IBGN=LSTCHR+1
C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
C FOR ERROR...
1000    RETURN
300    CONTINUE
    RETCD=3
    RETURN
    END
c -h- postvl.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE POSTVL (RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *

C *      SUBROUTINE  POSTVL (RETCD)                *
C *                                                *
C **************************************************
C
C
C  CONVERTS POSTFIX EXPRESSIONS IN STACK 1 TO A VALUE
C
C
C    RETCD    MEANING
C
C    1    O.K.
C    2    ERROR
C
C POSTVL CALLS
C
C CALBIN    CALCULATES BINARY OPERATIONS
C CALUN     CALCULATES UNARY OPERATIONS
C ERRMSG    PRINTS OUT ERROR MESSAGES
C VAROUT    OUTPUTS THE VALUE OF A VARIABLE
C
C
C
C
C POSTVL IS CALLED BY CALC
C
C
C
C
C VARIABLE    USE
C _________ ___________________________
C
C    I,K     TEMPORARY VALUES
C
C    PT1     POINTS TO TOP ELEMENT IN STACK1
C
C    RETCD   RETURN CODE: 1=O.K., 2=ERROR
C
C    RETCD2  USED TO HOLD RETURN CODE WHEN CALLS TO
C            OTHER ROUTINES ARE MADE.
C
C    ST1PT   STACK 1 POINTER.
C
C    ST2PT   STACK 2 POINTER.
C
C    ST1TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 1
C
C    ST2TYP  VECTOR OF TYPES FOR EACH ELEMENT IN STACK 2
C
C    STACK1  HOLDS ORIGINAL POSTFIX EXPRESSION.
C
C    STACK2  USED TO EVALUATE EXPRESSION IN STACK1.
C
C    TYPE(27) HOLDS THE DATA TYPE FOR EACH OF THE VARIABLES.
C
C    AVBLS(100,27) HOLDS VALUES OF VARIABLES.
C    VBLS(8,60,301) HOLDS VALUE OF COMPLEXLY-NAMED VARIABLES. 1ST 27 ELEMENTS
C    ARE PLACE HOLDERS FOR AVBLS; ROUTINES THAT GENERATE DIMENSIONS ID1,ID2
C    FOR VBLS RETURN DIMENSIONS 1-27,1 FOR A-Z,%. THESE RESULT IN AVBLS
C    ARRAY BEING USED. VBLS ARRAY (MAX LENGTH 8 BYTES/VARIABLE) IS USED
C    FOR OTHER VARIABLES WHOSE NAMES ARE <ALPHA><ALPHA><NUM><NUM>
C    (WITH OPTION FOR ANY REASONABLE # OF ALPHAS AND NUMERICS BUT CLAMPED
C    AT 60,301 VALUES TO WORK CORRECTLY.)
C
C    VIEWSW   VIEW SWITCH:
C                0 = OFF
C                1 = DISPLAY COMMANDS
C                2 = DISPLAY VALUE OF EXPRESSIONS
C                3 = DISPLAY ALL
C
C
C
C    SUBROUTINE POSTVL (RETCD)
C
    InTeGer*4 LEVEL,NONBLK,LEND
    InTeGer*4 PT1
    InTeGer*4 VIEWSW,BASED
    InTeGer*4 RETCD,RETCD2,VLEN(9)
    InTeGer*4 TYPE(1,1)
    InTeGer*4 ST1TYP(40),ST2TYP(40)
    InTeGer*4 ST1LIM,ST2LIM,ST1PT,ST2PT
    InTeGer*4 I,K
C
    CHARACTER*1 LINE(80)
    CHARACTER*1 STACK1(8,40), STACK2(8,40),AVBLS(20,27)
    CHARACTER*1 VBLS(8,1,1)
C
    COMMON /STACK/ STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
     ;           ST1LIM,ST2LIM
    COMMON /V/ TYPE,AVBLS,VBLS,VLEN
    COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
C
C
    RETCD=1
C
C
C IF THERE IS ONE ELEMENT IN STACK1 AND IT IS NOT
C A NUMBER, THE EXPRESSION IS ILLEGAL (GO TO 95).
    IF(ST1PT.EQ.2.AND.ST1TYP(1).GT.30)GO TO 95
C
C
10    IF (ST1PT.GT.2) GOTO 40
    IF (ST1PT.EQ.1) GOTO 95
C
C
C ***************************************
C ****** ONLY 1 ELEMENT ON STACK 1 ******
C ***************************************
    K=VLEN(ST1TYP(ST1PT-1))
C
C
C COPY INTO VARIABLE %
    DO 20 I=1,K
20    AVBLS(I,27)=STACK1(I,1)
    CALL TYPSET(27,1,ST1TYP(1))
C    TYPE(27,1)=ST1TYP(1)
C
C
C OUTPUT VALUE OF %
    IF (VIEWSW.GT.1) CALL VAROUT(27,1)
    RETURN
C
C
C  MORE THAN ONE ELEMENT ON STACK1
40    CONTINUE
    IF (ST1TYP(ST1PT-1).LE.30) GOTO 90
    IF (ST2PT.LE.ST2LIM) GOTO 45
C
C
C *** ERROR *** STACK 2 OVERFLOW
    CALL ERRMSG(9)
43    RETCD=2
    RETURN
C
C
C
C
C ****************************************
C ****** OPERATOR SO PUT ON STACK 2 ******
C ****************************************
45    ST2TYP(ST2PT)=ST1TYP(ST1PT-1)
    ST2PT=ST2PT+1
    ST1PT=ST1PT-1
    IF(ST1PT.EQ.1)GO TO 95
    GOTO 40
C
C
C
C
C
C *********************
C ****** OPERAND ******
C *********************
C
C FIRST BE SURE THAT THERE IS AN OPERATOR INVOLVED ON STACK 2
C (IF ONLY ONE ELEMENT IN STACK 1 YOU SHOULD NOT BE HERE).
90    IF(ST2PT.NE.1)GO TO 110
C
C
C *** ERROR *** ILLLEGAL EXPRESSION
95    CALL ERRMSG(8)
    GO TO 43
C
C
C
C
C ENTER HERE AFTER APPLYING AN OPERATOR TO A NUMBER
100    IF (ST2PT.EQ.1) GOTO 10
110    K=ST2TYP(ST2PT-1)
C
C IF A UNARY OPERATOR, GO TO 190
    IF ((K.GT.30.AND.K.LE.47).OR.K.EQ.111) GOTO 190
C
C
C IF A BINARY OPERATOR, GO TO 170
    IF (K.GE.110.AND.K.LE.117) GOTO 170
    IF(K.EQ.200)GO TO 170
C
C IF ELEMENT ON STACK2 AT ST2PT-1 IS AN OPERAND, APPLY CALBIN AGAIN
    IF(K.LE.30) GO TO 180
    STOP 110
C
C
C
C
C ***************************************************************
C ****** CALBIN CALCULATES THE BINARY VALUE OF AN OPERATOR ******
C ***************************************************************
C  UPON ENTRANCE:
C    OPERAND 1 IS IN STACK 1
C    OPERAND 2 IS IN STACK 2
C    OPERATOR IS BELOW OPERAND 2
C  UPON EXIT RESULT IS ON STACK 1
C
C    RETURN CODE    MEANING
C
C    1        O.K.
C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C    3        ERROR ENCOUNTERED
C
C
170    CONTINUE
C
C
C FIRST PUT OPERAND 2 ONTO STACK 2
    PT1=ST1PT-1
    ST2TYP(ST2PT)=ST1TYP(PT1)
    K=VLEN(ST2TYP(ST2PT))
    DO 175 I=1,K
175    STACK2(I,ST2PT)=STACK1(I,PT1)
    ST1PT=ST1PT-1
    IF(ST1PT.EQ.1)GO TO 95
    ST2PT=ST2PT+1
C
C
C IF OPERAND 1 IS AN OPERATOR, PUT IT ON STACK 2 (GO TO 45)
    IF(ST1TYP(ST1PT-1).GT.30) GO TO 45
180    CALL CALBIN (RETCD2)
    GOTO (100,1000,43), RETCD2
    STOP 180
C
C
C
C
C
C ********************************************************************
C ****** CALL CALUN TO CALCULATE THE VALUE OF A UNARY OPERATION ******
C ********************************************************************
C    OPERATOR IS IN STACK 2
C    OPERAND IS IN STACK 1
C    UPON EXIT, OPERATOR IS POPPED OFF STACK 2
C
C    RETURN CODE    MEANING
C
C    1        O.K.
C    2        OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C    3        ERROR ENCOUNTERED
C
C
190    CALL CALUN (RETCD2)
    GOTO(100,43),RETCD2
    STOP 190
C
C
1000    RETURN
    END
c -h- prtcon.for    Tue Sep  2 10:58:55 1986
C **********************************
C *                                *
C *    INTERNAL FUNCTION PRTCON    *
C *                                *
C **********************************
C CALLED BY MOUT ONLY
C CONVERTS 0 TO APPROPRIATE NUMBER FOR PRINTING WITH VECTOR DIGITS
    FUNCTION PRTCON(L1,IBASE)
    InTeGer*4 BASE(3)
    InTeGer*4 IBASE,K
    CHARACTER*1 L1,PRTCON,DIGITS(16,3)
    COMMON /DIGV/ DIGITS
    DATA BASE /10,8,16/
    PRTCON=L1
    IF(L1.EQ.0)PRTCON=CHAR(BASE(IBASE))
    K=ICHAR(PRTCON)
    PRTCON=DIGITS(K,IBASE)
    RETURN
    END
c -h- rassig.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE RASSIG(IUNIT,NAME)
C
C
    CHARACTER*1 NAME(50)
    InTeGer*4 IUNIT
C &&&& MS FTN 3.2
    LOGICAL LEXIST
C &&&&
    CHARACTER*20 WK
    CHARACTER*1 WK1(20)
    EQUIVALENCE(WK(1:1),WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
    DO 1 N=1,20
    WK1(N)=' '
1    CONTINUE
    DO 2 N=1,20
    II=ICHAR(NAME(N))
    IF(II.LT.32)GOTO 3
    WK1(N)=CHAR(II)
C1    CONTINUE
2    CONTINUE
3    CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
    INQUIRE(FILE=WK(1:20),EXIST=LEXIST)
    IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
c    CALL UVT100(1,1,1)
c    CALL SWRT('File not found. Attempting to create.',37)
c    OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
c     1  FORM='FORMATTED')
c    CLOSE(IUNIT)
c
c On failure to open a file, create a window instead which
c can be its surrogate...
c
    Open(Iunit,file='CON:200/100/400/60/RdErr ' // wk,
     1  Access='Sequential',form='Formatted')
C OPENS AND CLOSES FILE, CREATING A NULL FILE TO READ.
C WILL GET EOF ON START, BUT THAT'S TOO BAD...
    Goto 77
100    CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
    OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77    CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
    RETURN
    END
c -h- recalc.f40    Tue Sep  2 10:58:55 1986
    SUBROUTINE RECALC
C COPYRIGHT (C) 1983,1984,1985,1986 GLENN EVERHART
C ALL RIGHTS RESERVED
C RECALCULATE COMMAND
C RECOMPUTE ALL ELEMENTS OF SPREADSHEET WHERE VALID.
C PARAMETER 18060=60*301
C NOTE: THROUGHOUT, ROWS ARE ACTUALLY DOWN, COLUMNS ACROSS ON
C SCREEN. ROW 0 IN DISPLAY IS THE 27 ACCUMULATORS A-Z AND %, WITH
C % BEING THE LAST-COMPUTED VALUE FROM THE CALC PROGRAM, WHICH
C KNOWS HOW TO ACCESS THE DATA BUT IS JUST PASSED COMMAND STRINGS
C FROM THE DISK BASED FILE HERE.
    CHARACTER*1 FORM,FVLD,CMDLIN(132)
    INTEGER*4 VNLT
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
CCCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,
CCCC     1  IRCE1,IRCE2
C ***<<< KLSTO COMMON START >>>***
    InTeGer*4 DLFG
C    COMMON/DLFG/DLFG
    InTeGer*4 KDRW,KDCL
C    COMMON/DOT/KDRW,KDCL
    InTeGer*4 DTRENA
C    COMMON/DTRCMN/DTRENA
    REAL*8 EP,PV,FV
    DIMENSION EP(20)
    INTEGER*4 KIRR
C    COMMON/ERNPER/EP,PV,FV,KIRR
    InTeGer*4 LASTOP
C    COMMON/ERROR/LASTOP
    CHARACTER*1 FMTDAT(9,76)
C    COMMON/FMTBFR/FMTDAT
    CHARACTER*1 EDNAM(16)
C    COMMON/EDNAM/EDNAM
    InTeGer*4 MFID(2),MFMOD(2)
C    COMMON/FRM/MFID,MFMOD
    InTeGer*4 JMVFG,JMVOLD
C    COMMON/FUBAR/JMVFG,JMVOLD
    COMMON/KLSTO/DLFG,KDRW,KDCL,DTRENA,EP,PV,FV,KIRR,
     1  LASTOP,FMTDAT,EDNAM,MFID,MFMOD,JMVFG,JMVOLD
C ***<<< KLSTO COMMON END >>>***
CCC    InTeGer*4 DLFG
CCC    COMMON/DLFG/DLFG
C DLFG=1 IF D## FORMS HAVE BEEN SEEN, ELSE 0
    DIMENSION FORM(128),FVLD(1,1)
    COMMON/FVLDC/FVLD
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=-2 OR -3 = DISPLAY FORMULA
C FVLD=3 NUMERIC, COMPUTE ONCE THEN SET FVLD TO 2
C FVLD=2 NUMERIC CONSTANT, ALREADY COMPUTED... DO NOT RECOMPUTE.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV
CCC    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    DIMENSION NRDSP(20,75),NCDSP(20,75)
    COMMON/D2R/NRDSP,NCDSP
    InTeGer*4 TYPE(1,1),VLEN(9)
    CHARACTER*1 AVBLS(20,27),VBLS(8,1,1)
CCC    InTeGer*4 RRWACT,RCLACT
CCC    COMMON/RCLACT/RRWACT,RCLACT
CCC    InTeGer*4 KDRW,KDCL
CCC    COMMON /DOT/KDRW,KDCL
    COMMON/V/TYPE,AVBLS,VBLS,VLEN
    InTeGer*4 PRS,PCS,DRS,DCS
    PRS=PROW
    PCS=PCOL
    DRS=DROW
    DCS=DCOL
    IF(RCMODE.EQ.2)GOTO 5500
C THE FOLLOWING 2 LOOPS DEFINE ORDER OF CALCULATION.
C HERE THIS IS: OUTER LOOP ON ROWS (ACROSS), INNER LOOP ON COLUMNS (DOWN).
C NOTE THAT N2 DEFINES THE SHEET. SINCE 1 IS THE ACCUMULATORS, JUST GO THRU
C FOR THE SHEET, NOT THE AC'S.
    DO 1 N2=2,RCLACT
    N1=1
220    CONTINUE
C    DO 2 N1=1,60
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
C
CCCC COMMENT 2 LINES OUT WHEN FAST FVLDGT IS IN TO SPEED UP MORE...
CCCC EXTRA LOGIC IN FVPEEK DOESN'T USUALLY PAY FOR ITSELF...
CCC    CALL FVPEEK(N1,N2,NN1)
CCC    N1=NN1
    CALL FVLDGT(N1,N2,FVLD(1,1))
    IIFV=JCHAR(FVLD(1,1))
    IF (IIFV.LE.0) GOTO 2
    IRRX=(N2-1)*60+N1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
    IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 2
    KDRW=N1
    KDCL=N2
    PROW=N1
    PCOL=N2
C SEE IF THIS PHYS COL HAS A DISPLAY COL. AND IF SO SET THAT UP.
C ONLY SET TO DISPLAYED LOCS HERE TO MINIMIZE SEARCH TIME.
C NEED THIS TO HANDLE D## FORMS...
    IF (DLFG.EQ.0)GOTO 95
C IF NEVER HAD A D## FORM FORGET LOOKING FOR DISPLAY LOCS.
    DO 20 M2=1,DCLV
    DO 10 M1=1,DRWV
    M1X=M1
    M2X=M2
C LOOK FOR DISPLAY COORDS EVEN IF IN HYPERSPACE
C WE FIND ONE IF INDEX FROM REFLECT IS SAME AS WHAT
C WE'RE LOOKING FOR...
    IF(NRDSP(M1,M2).EQ.N1.AND.NCDSP(M1,M2).EQ.N2)GOTO 9
10    CONTINUE
20    CONTINUE
95    CONTINUE
C HERE IF CELL NOT DISPLAYED... SEE IF NEEDS DOING IN RI, RE MODES
    IF(RCMODE.LE.0)GOTO 9
    IF(PROW.NE.IRCE1.OR.PCOL.NE.IRCE2)GOTO 2
C SKIP UNLESS ENTER CELL.
9    CONTINUE
C IF NO DISPLAY ROW, LEAVE AT LOW RIGHT...
C USE SAVED VALUES SO WE DON'T RELY ON DO LOOP INDEX AFTER LOOP END.
    DROW=M1X
    DCOL=M2X
    CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
    LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
    DO 56 N=1,109
    LLST=111-N
    IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 57
    FORM(LLST)=Char(0)
56    CONTINUE
57    CONTINUE
    FORM(LLST)=Char(0)
    FORM(111)=Char(0)
C    IF(ICHAR(FORM(118)).NE.15)GOTO 2
    CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
C    CALL FVLDGT(N1,N2,FVLD(1,1))
    IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
2    CONTINUE
    N1=N1+1
    IF(N1.LE.RRWACT)GOTO 220
1    CONTINUE
    GOTO 5600
5500    CONTINUE
C RCMODE=2 AND NOT RM MODE
C (IN RM MODE, RECALC IS NOT CALLED...)
    DO 1701 M2=1,DCLV
    DO 1702 M1=1,DRWV
C TO HANDLE DISPLAY WHEREVER IT MAY BE, FIND ID OF PHYS CELL AND
C CONVERT TO PHYS ROW, COL AGAIN REGARDLESS OF ALIAS...
C (NOTE CALC ORDER IS THEREFORE DISPLAY ORDER, NOT SHEET ORDER...)
    K=NRDSP(M1,M2)
    KK=NCDSP(M1,M2)
    CALL REFLECT(KK,K,IV1)
    NRC=IV1-1
    N1=MOD(NRC,60)+1
    N2=((NRC-N1+1)/60)+1
C COMPUTE PHYS ROW, COL FROM DISPLAY COORDINATES.
C USE FVPEEK TO CHECK WHERE FIRST CELL TO DO IS HERE. SHOULD BE
C FASTER THAN STANDARD LOOP METHOD.
C *** NOTE HOWEVER THAT IT COULD SLOW US UP... DEPENDS ON EFFICIENCY
C OF FVLDGT AND FVPEEK.
C  ... NEED BADLY TO SPEED UP FVLDGT AND FVPEEK TO GET THIS LOOP TO RUN FAST.
    CALL FVLDGT(N1,N2,FVLD(1,1))
    IIFV=JCHAR(FVLD(1,1))
    IF (IIFV.LE.0) GOTO 1702
C FORGET THIS CELL IF NOT A COMPUTABLE ONE...
    IRRX=IV1
C IF CONSTANT WAS COMPUTED ALREADY, NO NEED TO RECOMPUTE. SKIP IT.
C NOTE: WE MUST ALWAYS RECOMPUTE IF R COMMAND WAS GIVEN...
    IF ((RCONE.EQ.0).AND.(ICHAR(FVLD(1,1)).EQ.2)) GOTO 1702
    KDRW=N1
    KDCL=N2
    PROW=N1
    PCOL=N2
    DROW=M1
    DCOL=M2
    CALL WRKFIL(IRRX,FORM,0)
C NOW HAVE THE FORMULA LINE. PASS TO DOENTRY TO HANDLE IT.
    LFST=1
C FIND END OF FORMULA FOR MATH ROUTINES TO TRY TO SPEED
C THEM UP A BIT.
C (ALSO GUARANTEE WE HAVE LOTS OF NULLS AT END TO TERMINATE INDEX ROUTINES)
    DO 756 N=1,109
    LLST=111-N
    IF(ICHAR(FORM(LLST-1)).GT.32)GOTO 757
    FORM(LLST)=Char(0)
756    CONTINUE
757    CONTINUE
    FORM(LLST)=Char(0)
    FORM(111)=Char(0)
C CALL DOENTR TO DO THE ACTUAL COMPUTATION WORK...
    CALL DOENTR(FORM,LFST,LLST)
C IF WE JUST COMPUTED A CONSTANT, FLAG IT COMPUTED AND SKIP IT.
    IF(IIFV.EQ.3)CALL FVLDST(N1,N2,Char(2))
1702    CONTINUE
1701    CONTINUE
C END OF COMPUTATION OVER DISPLAYS
C    GOTO 5600
5600    CONTINUE
    PROW=PRS
    PCOL=PCS
    DROW=DRS
    DCOL=DCOL
C FORCE FUNCTION WORKS ONCE ONLY.
    RCONE=0
    RCMODE=IABS(RCMODE)
C SET FOR TEMP. RECALC-ALL MODES TO RETURN TO NORMAL.
    IRCE1=0
    IRCE2=0
    RETURN
    END
c -h- reflect.f40    Tue Sep  2 10:58:55 1986
    SUBROUTINE REFLEC(ID1,ID2,ID)
C FORM ID OUT OF ID1,ID2 BUT USING REFLECTED VALUES SO THAT
C RESULT ID IS ALWAYS IN PRIME AREA.
    InTeGer*4 ID,ID1,ID2,IDD1,IDD2
C ***<<< NULETC COMMON START >>>***
    InTeGer*4 ICREF,IRREF
C    COMMON/MIRROR/ICREF,IRREF
    InTeGer*4 MODPUB,LIMODE
C    COMMON/MODPUB/MODPUB,LIMODE
    InTeGer*4 KLKC,KLKR
    REAL*8 AACP,AACQ
C    COMMON/MSCMN/KLKC,KLKR,AACP,AACQ
    InTeGer*4 NCEL,NXINI
C    COMMON/NCEL/NCEL,NXINI
    CHARACTER*1 NAMARY(20,301)
C    COMMON/NMNMNM/NAMARY
    InTeGer*4 NULAST,LFVD
C    COMMON/NULXXX/NULAST,LFVD
    COMMON/NULETC/ICREF,IRREF,MODPUB,LIMODE,
     1  KLKC,KLKR,AACP,AACQ,NCEL,NXINI,NAMARY,NULAST,LFVD
C ***<<< NULETC COMMON END >>>***
CCC    COMMON/MIRROR/ICREF,IRREF
C IN RECALC WE MOVE OVER PRIME AREA ONLY AND SEARCH FOR CELLS IN
C DISPLAY AREA THERE. THIS IMPLIES THAT WE DON'T FIND DISPLAY
C COORDS OF CELLS IN EXTENDED AREAS THERE.  THEREFORE THE RI AND RE
C MODES FAIL COMPLETELY THERE. SINCE WE WANT THE SYSTEM TO WORK IN
C A PREDICTABLE WAY, FORCE RECALC MODE (I.E., R OR RM MODES) THERE TO
C ALLOW CELLS TO BE COMPUTED.
C NOTE THAT IF WE ARE IN THE PRIME AREA AND ISSUE AN RE OR RI COMMAND,
C THAT MODE SHOULD STAY SET SO LONG AS WE STAY THERE SINCE THE RE OR
C RI MODES WILL INHIBIT COMPUTING OUTSIDE THAT AREA (AS LONG AS NOTHING
C REFLECTS INTO IT) SO THERE WILL BE NO REASON FOR THIS TO BE CALLED
C TO REFLECT SOMETHING BACK TO PRIME AREA UNTIL A R COMMAND IS GIVEN
C OR THE DISPLAY MOVES OFF THE EDGE OF THE PRIME 60 BY 301 AREA.
C
C ***<<< XVXTCD COMMON START >>>***
    CHARACTER*1 OARRY(100)
    InTeGer*4 OSWIT,OCNTR
C    COMMON/OAR/OSWIT,OCNTR,OARRY
C COMMON OAR SWITCHES OUTPUT OFF IF OSWIT=2
    InTeGer*4 IPS1,IPS2,MODFLG
C    COMMON/ICPOS/IPS1,IPS2,MODFLG
       InTeGer*4 XTCFG,IPSET,XTNCNT
       CHARACTER*1 XTNCMD(80)
C       COMMON/XCMD/XTNCNT,XTNCMD,XTCFG,IPSET
C VARY FLAG ITERATION COUNT
    INTEGER KALKIT
C    COMMON/VARYIT/KALKIT
    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE
    InTeGer*4 RCMODE,IRCE1,IRCE2
C    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
C     1  IRCE2
C FORMFG FLAGS FORMAT OF DISPLAY GLOBALLY
C RCFGX FLAGS WHETHER TO DO AUTO RECALCULATION. IF 1, INHIBITS
C AUTO RECALC (USE R COMMAND TO DO A CALC.). 17 COMMAND TURNS
C RCFGX ON.
C PZAP CONTROLS WHETHER TO REDRAW SCREEN. IF ZERO, NORMAL. IF 1
C (NONZERO ANYHOW), INHIBITS RE DISPLAY. V COMMAND RESETS TO 0
C  AND VM INHIBITS. (SETS TO 1).
    INTEGER*4 FH
C FILE HANDLE FOR CONSOLE I/O (RAW)
C    COMMON/CONSFH/FH
    CHARACTER*1 ARGSTR(52,4)
C    COMMON/ARGSTR/ARGSTR
    COMMON/XVXTCD/OSWIT,OCNTR,OARRY,IPS1,IPS2,MODFLG,
     1  XTNCNT,XTNCMD,XTCFG,IPSET,KALKIT,
     2  FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,
     3  IRCE2,FH,ARGSTR
C ***<<< XVXTCD COMMON END >>>***
CCC    InTeGer*4 FORMFG,RCFGX,PZAP,RCONE,RCMODE
CCC    InTeGer*4 IRCE1,IRCE2
CCC    COMMON/FFGG/FORMFG,RCFGX,PZAP,RCONE,RCMODE,IRCE1,IRCE2
    IDD1=MAX0(ID1,1)
    IDD2=ID2
C ACCEPT TRICK CALLS WITH ID1=0 AS FROM GMSUBS, MTXEQU,
C AND MDST
    IF(ID1.LT.1)GOTO 2000
4000    CONTINUE
    IF(IDD2.LE.60)GOTO 1000
    IDD2=IDD2-60
    IDD1=IDD1+IRREF
c    RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
    GOTO 4000
1000    CONTINUE
    IF(IDD1.LE.301)GOTO 2000
    IDD1=IDD1-300
    IDD2=IDD2+ICREF
c    RCMODE=0
C RI AND RE MODES FAIL OUT OF PRIME AREA SO DISABLE THEM
    GOTO 4000
2000    CONTINUE
    ID=(IDD1-1)*60+IDD2
    RETURN
    END
c -h- relvbl.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE RELVBL(LNIN,LNOUT,INRW,INCL,JOUTR,JOUTC,JRTR,JRTC)
C RELOCATE VARIABLES BELOW/RIGHT OF JRTR,JRTC INTO LNOUT FROM LNIN
C    PARAMETER CUP=1,ED=11,EL=12
    CHARACTER*1 NAME(4),NUMBER(6)
    CHARACTER*1 LNIN,LNOUT
    CHARACTER*6 NUMBR6
    EQUIVALENCE(NUMBR6(1:1),NUMBER(1))
    DIMENSION LNIN(128),LNOUT(128)
C ***<<<< RDD COMMON START >>>***
    InTeGer*4 RRWACT,RCLACT
C    COMMON/RCLACT/RRWACT,RCLACT
    InTeGer*4 idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8
C    common/dollr/idol1,idol2,idol3,idol4,idol5,idol6,
C     1  IDOL7,IDOL8
    InTeGer*4 PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP
C    COMMON/DCTL/PROW,PCOL,DROW,DCOL,DRWV,DCLV
    InTeGer*4 IPGMAX,LPGMXF,IPGMOD,LPGMOD
C    COMMON/FILEMX/IPGMAX,LPGMXF,IPGMOD,LPGMOD
C LENGTHS (IN K) OF FILES FOR VALUES OR FORMULAS ARE IPGMAX,LPGMXF
C IPGMOD AND LPGMOD CONTROL PACKING MODE IN THE CORRESPONDING FILES
    InTeGer*4 KLVL
C    COMMON/KLVL/KLVL
    InTeGer*4 IOLVL,IGOLD
C    COMMON/IOLVL/IOLVL
C IOLVL IS LUN FOR XQTCMD TO USE (NORMALLY 3 FOR INDIRECT FILES OR 5
C FOR TERMINAL. WE USE 5,6 FOR TERMINAL INPUT, OUTPUT NORMALLY.
    COMMON/RDD/RRWACT,RCLACT,idol1,idol2,idol3,idol4,idol5,idol6,
     1  IDOL7,IDOL8,PROW,PCOL,DROW,DCOL,DRWV,DCLV,LLCMD,LLDSP,
     2  IPGMAX,LPGMXF,IPGMOD,LPGMOD,KLVL,IOLVL,IGOLD
C ***<<< RDD COMMON END >>>***
CCC    InTeGer*4 IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
CCC    COMMON/DOLLR/IDOL1,IDOL2,IDOL3,IDOL4,IDOL5,IDOL6
C    LOGICAL*2 L63,L192,L255,L127,L128
    LOGICAL*4 L1,L2
C    InTeGer*4 I63,I192,I255,I127,I128
    InTeGer*4 I63,I192,I127
    InTeGer*4 I1,I2
C    EQUIVALENCE(I63,L63),(I192,L192),(I255,L255)
    EQUIVALENCE (I1,L1),(I2,L2)
C    EQUIVALENCE (L127,I127),(L128,I128)
C    DATA I63/63/,I192/192/,I255/255/,I127/127/,I128/128/
    DATA I63/63/,I192/192/,I127/127/
    LI=1
    LO=1
C LI = INPUT LOCATION
C LO=OUTPUT LOCATION
100    CONTINUE
C    IF(LNIN(LI).LT.'A'.OR.LNIN(LI).GT.'Z')GOTO 200
    LCC=ICHAR(LNIN(LI))
C IF WE HAVE 255,CODE,CODE THEN RELOCATE IN BINARY...
    IF(LCC.EQ.255)GOTO 500
    IF(LCC.LT.65.OR.LCC.GT.89)GOTO 200
C WE MUST ENSURE VARSCN ALWAYS SEES AN ALPHA AT START.
    IL1=LI
    LE=110
    LSTC=LE
    CALL VARSCN(LNIN,IL1,LE,LSTC,ID1,ID2,IVLD)
C AVOID MESSING UP FUNCTION NAMES
    IF(ID2.EQ.1)IVLD=0
C    IF(ID2.EQ.1.AND.ID1.LE.27)IVLD=0
    IF(IVLD.EQ.0)GOTO 200
C FOUND VARIABLE. NOW GENERATE ASCII ANDSTUFF INTO OUTPUT.
C FIRST DON'T RELOCATE P## AND D## FORMS.
    IF(LNIN(LI+1).EQ.'#')GOTO 250
C RELOCATE NORMAL VARIABLE HERE.
C
C THE NEW VARIABLE IS TO BE DIFFERENT ONLY IF (ID1,ID2) HAS
C ID1.GT.JRTR AND ID2.GT.JRTC
    IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 210
    IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 210
C OK, KNOW NOW THAT WE HAVE TO RELOCATE ALL.
C THEREFORE ADD THE DIFFERENCE BETWEEN DEST AND SRC TO BOTH
C AND CLAMP TO VALID DIMENSIONS.
    IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
    IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
906    ID1=MAX0(ID1,1)
    ID2=MAX0(ID2,1)
C CAN UNPACK THIS STUFF ALL RIGHT IN EXTENDED WAYS.
    ID1=MIN0(18060,ID1)
    ID2=MIN0(18060,ID2)

210    CONTINUE
    CALL IN2AS(ID1,NAME)
C NAME GETS 4 CHARACTERS TO USE FOR COL. LABEL
    IL2=ID2-1
    WRITE(NUMBR6(1:6),1000)IL2
C    ENCODE(6,1000,NUMBER)IL2
1000    FORMAT(I6)
C NOW NAME AND NUMBER ARRAYS HAVE LETTERS, DIGITS, OR SPACES.
C THROW OUT SPACES AND COPY THE REST.
    LI=LSTC
    DO 202 N=1,4
    IF(Ichar(NAME(N)).LE.32)GOTO 202
    LNOUT(LO)=NAME(N)
    LO=LO+1
    IF(LO.GT.110)GOTO 300
202    CONTINUE
    IF(IDOL1.GT.0)LNOUT(LO)=36
    IF(IDOL1.GT.0.AND.LO.LE.109)LO=LO+1
    DO 203 N=1,6
    IF(ICHAR(NUMBER(N)).LE.32)GOTO 203
C IF 32 ISN'T SPACE, LOSE
    LNOUT(LO)=NUMBER(N)
    LO=LO+1
    IF(LO.GT.110)GOTO 300
203    CONTINUE
    IF(IDOL2.EQ.0)GOTO 300
    LNOUT(LO)=CHAR(36)
    IF(LO.LE.109)LO=LO+1
    GOTO 300
250    CONTINUE
C JUST COPY DISPLAY FORMS.
    IL1=LSTC-1
    DO 251 N=LI,IL1
    LNOUT(LO)=LNIN(N)
    LO=LO+1
    IF(LO.GT.110)GOTO 300
251    CONTINUE
    LI=LSTC
C THIS SKIPS OVER THE VARIABLE FOUND, SO WE GO ON.
    GOTO 300
200    LNOUT(LO)=LNIN(LI)
    LO=LO+1
    LI=LI+1
300    IF(LO.LT.109.AND.LI.LT.109)GOTO 100
C THIS LOOPS EITHER COPYING LINE OR FINDING VARIABLES TILL DONE.
    LO=MIN0(LO,110)
    DO 400 N=LO,110
400    LNOUT(N)=0
    DO 1 N=111,128
1    LNOUT(N)=LNIN(N)
C DEFAULT ALL OF FORM LINES EXCEPT FORMULA IDENTICAL TO THE INPUT.
    RETURN
500    CONTINUE
C DECODE BY HAND...
    LNOUT(LO)=LNIN(LI)
    I1=ICHAR(LNIN(LI+1))
    I2=IMASK(I1,I192)
C    L2=L1.AND.L192
    I1=IMASK(I1,I63)
C    L1=L1.AND.L63
C DO MASKING TO GET BINARY COORDS
    ID1=I1
    I1=ICHAR(LNIN(LI+2))
    I1=IMASK(I1,I127)
C    L1=L1.AND.L127
    ID2=I2*2+I1
C NOW RELOCATE AND PUT BACK
    IF(ID1.LT.JRTR.OR.ID2.LT.JRTC)GOTO 510
    IF(ID1.GT.IDOL5.OR.ID2.GT.IDOL6)GOTO 510
    IF(IDOL3.NE.0.OR.IDOL1.EQ.0)ID1=ID1+(JOUTR-INRW)
    IF(IDOL3.NE.0.OR.IDOL2.EQ.0)ID2=ID2+(JOUTC-INCL)
C CLAMP RESULT TO MAX RANGES
    ID1=MAX0(ID1,1)
    ID2=MAX0(ID2,1)
C DO GENERAL REPACK IF ID1 OR ID2 ARE EXTENDED RANGE.
    IF(ID1.GT.60.OR.ID2.GT.301)GOTO 905
C    ID1=MIN0(60,ID1)
C    ID2=MIN0(301,ID2)
510    CONTINUE
C RELOCATED, NOW REPACK AS NEW BINARY PATTERNS
    I1=ID1
C    L1=L1.AND.L63
    I1=IMASK(I1,I63)
    I2=ID2/2
    I2=IMASK(I2,I192)
C    L2=L2.AND.L192
C    L1=L1.OR.L2
    I1=I1+I2
    LNOUT(LO+1)=CHAR(I1)
    I2=ID2
    I2=IMASK(I2,I127)+128
C    L2=L2.AND.L127
C    L2=L2.OR.L128
C BE SURE AT LEAST 1 BIT IS SET
    LNOUT(LO+2)=CHAR(I2)
    LI=MIN0(109,LI+3)
    LO=MIN0(109,LO+3)
C GO LOOK FOR MORE TO DECODE
    GOTO 300
905    CONTINUE
C HERE SET UP FOR REENTRY INTO "NORMAL" DECODE
    LSTC=MIN0(109,LI+3)
    GOTO 906
    END
c -h- rnd.for    Tue Sep  2 10:58:55 1986
    FUNCTION RND(DUM)
C GENERATE RANDOM NUMBER BY LINEAR CONGRUENCE IN BIG
C INTEGERS.
    REAL*4 R
    INTEGER*4 DUM
    INTEGER*4 I,II
    LOGICAL*4 L,LMSK
    REAL*8 XX
    EQUIVALENCE(I,L),(II,LMSK)
    I=DUM
    XX=I
    XX=XX*214013.0D0+2531011.0D0
    IF(XX.LT.0.)XX=1.0D0-XX
    XX=DMOD(XX,16777216.0D0)
    I=IDINT(XX)
C    I=I*214013+2531011
C USE MASKING TO ZOT THIS INTO NORMAL RANGE
C JUST USE MODULO...
    IF(I.LT.0)I=1-I
    IF(I.LT.0)I=0
    I=MOD(I,16777215)
    DUM=I
C RETURN RANDOM BETWEEN 0 AND 1.0
C PERIOD OF 2**24 MAX
    XX=I
    XX=XX/16777216.0
    R=SNGL(XX)
    RND=R
    RETURN
    END
c -h- rvboo.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE RVBOO(RETV,ID1,ID2)
C THIS ROUTINE ONLY COPIES ID1,ID2 INTO RETV ARRAY TO AVOID SOME
C BYTE-INTEGER CONVERSION PROBLEMS. THIS PACKING IS USED TO
C ACCESS VARIABLE LOCATION LATER.
    InTeGer*4 RETV,ID1,ID2
    DIMENSION RETV(2)
    RETV(1)=ID1
    RETV(2)=ID2
    RETURN
    END
c -h- scmp.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SCMP(LINA,LINB,LENM,ICODE)
    DIMENSION LINA(1),LINB(1)
    CHARACTER*1 LINA,LINB
    ICODE=1
    DO 1 N=1,LENM
    IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
C ALLOW _ TO BE A WILDCARD.
    IF(LINA(N).EQ.'_'.OR.LINB(N).EQ.'_')GOTO 1
    IF(LINA(N).NE.LINB(N))ICODE=0
    IF(ICODE.NE.1)GOTO 2
1    CONTINUE
2    CONTINUE
    RETURN
    END
c -h- sed.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SED(LCMD,LIN,LWRK,ARGSTR,XAC,LENGTH)
    CHARACTER*1 LIN(1),LWRK(1),ARGSTR(52,4)
    CHARACTER*1 LCMD(1),LSU(10)
    EXTERNAL INDX
    CHARACTER*10 LSU10
    EQUIVALENCE (LSU10(1:10),LSU(1))
    INTEGER*4 III
    REAL*8 XAC
C
C OPERATION:
C EDIT LIN TO LWRK, WITH LENGTH VARIABLE HOLDING INPUT
C LENGTH IN CHARACTERS. LCMD HOLDS COMMAND LINE, WHICH
C ULTIMATELY GETS EDITED STRING COPIED BACK INTO IT.
C
C EDITS:
C  CHARACTER AT IDELIM IS DELIMITER. REPLACE STRING IN 1ST
C INTERVAL BETWEEN DELIMITERS WITH SECOND.
C  HOWEVER:
C  &1 TO &4 GET CONTENTS (UP TO NULL) OF ARGSTR(X,1) TO (X,4)
C
C  &5 RETURNS XAC VALUE CONVERTED TO DECIMAL INTEGER AND
C  PRINTED.
C  &6 RETURNS XAC VALUE CONVERTED TO ASCII CODE (1 BYTE) AND
C  INSERTED.
C XAC ENTERS WITH CONTENTS OF ACCUMULATOR Z (TO AVOID TOO MUCH
C DIFFICULTY IN USING IT OWING TO THE UBIQUITY OF USE OF %).
C    WE ENTER JUST POINTING AT THE COMMAND LINE AFTER THE ENTER
C AND ITS SPACE. ASSUME 1ST CHARACTER IS OUR DELIMITER.
    DO 335 IV=1,80
335    LWRK(IV)=0
    IDELIM=ICHAR(LCMD(1))
    ID2=INDX(LCMD(2),IDELIM)
    IF(ID2.GE.LENGTH)GOTO 100
C NOW HAVE 1ST STRING, OF NONZERO LENGTH
C FIND SECOND STRING NOW. EITHER MAY BE OF 0 LENGTH BUT
C BOTH MUST BE DEFINED BY A DELIMITER.
    ID3=INDX(LCMD(2+ID2),IDELIM)
    IF(ID3.GE.LENGTH)GOTO 100
C WELL, WE GOT IT SOMEHOW. NOW TRY AND EDIT THE JUNK IN.
C (NOTE WE WANT TO FILL ALL OF LENGTH)
    INLIN=1
    INWRK=1
    IVV=ID3+ID2+2
    DO 336 IV=IVV,LENGTH
336    LCMD(IV)=0
    LSA=ID2-1
    LSB=ID3-1
    LSSB=2+ID2
    LZR=0
    DO 1 N=1,LENGTH
    IF(LSA.GT.0)GOTO 350
C ZERO LENGTH INITIAL STRING, SO ASSUME HE WANTS TO APPEND TO
C EXISTING STRING AT THE END.
C (HANDY FOR ADDING TO FORMULAE OR THE LIKE.)
    IF(LIN(N).EQ.0)GOTO 351
C JUST COPY THE INPUT FIRST AND GO OFF
    GOTO 2
351    CONTINUE
C HERE WE HAVE THE TERMINAL NULL
    LZR=LZR+1
C ALLOW US TO PRETEND FOR ONCE THAT WE GOT A MATCH
    IF(LZR.EQ.1)GOTO 222
    GOTO 1
350    CONTINUE
    IF(LIN(INLIN).EQ.0)GOTO 1
    CALL SSCMP(LIN(INLIN),LCMD(2),LSA,ICOD)
    IF(ICOD.EQ.0)GOTO 2
C HERE HAVE TO SUBSTITUTE
C PASS STRING TO SUBSTITUTE ON INPUT LINE FIRST.
222    CONTINUE
    INLIN=INLIN+LSA
C ALLOW ZERO LENGTH SUBSTITUTE CHARACTER
    IF(LSB.LE.0)GOTO 1
C    DO 6 M=1,LSB
    M=1
106    CONTINUE
    IF(LCMD(LSSB+M-1).EQ.'&')GOTO 7
8    CONTINUE
C JUST COPY ONE CHARACTER OF THE SUBSTITUTE STRING IN HERE.
    LWRK(INWRK)=LCMD(LSSB+M-1)
    IF(INWRK.LT.LENGTH)INWRK=INWRK+1
    GOTO 6
7    CONTINUE
C HANDLE & FORMS
    IF(LCMD(LSSB+M).LT.'1'.OR.LCMD(LSSB+M).GT.'6')GOTO 8
C REQUIRE ALL FORMS TO BE &1 THRU &6 TO BE DEALT WITH HERE.
    M=M+1
    IF(LCMD(LSSB+M-1).GT.'4')GOTO 10
C HERE JUST HANDLE ARGSTR SUBSTITUTIONS.
    II=ICHAR(LCMD(LSSB+M-1))
    II=II-48
C II IS NOW THE INDEX.
    DO 11 MM=1,52
    LWRK(INWRK)=ARGSTR(MM,II)
    IF(INWRK.LT.LENGTH)INWRK=INWRK+1
    IF(ARGSTR(MM,II).EQ.0)GOTO 12
11    CONTINUE
12    CONTINUE
    M=M+1
C PASS THE NUMBER OF THE &NUMBER FORM
    GOTO 6
10    CONTINUE
C HANDLE ZAC FORMS
    M=M+1
C PASS THE DIGIT
    IF(LCMD(LSSB+M-2).EQ.'5')GOTO 14
C FILL IN ZAC AS AN INTEGER
    II=32
    IF(XAC.GE.1.AND.XAC.LT.256.)II=XAC
C ONLY HANDLE CONVERSION IF LEGAL
    LWRK(INWRK)=CHAR(II)
    IF(INWRK.LT.LENGTH)INWRK=INWRK+1
    GOTO 6
14    CONTINUE
C HANDLE NUMERIC CONVERSION HERE
    LSU(1)=0
    III=0
    IF(DABS(XAC).LT.9999999.)III=IDINT(XAC)
    WRITE(LSU10(1:10),15,ERR=22)III
C    ENCODE(10,15,LSU,ERR=22)III
15    FORMAT(I9)
22    DO 16 MK=1,10
    IF(LSU(MK).EQ.0)GOTO 6
    IF(LSU(MK).EQ.' ')GOTO 16
    LWRK(INWRK)=LSU(MK)
    IF(INWRK.LT.LENGTH)INWRK=INWRK+1
16    CONTINUE
6    CONTINUE
    M=M+1
    IF(M.LE.LSB)GOTO 106
    GOTO 1
2    CONTINUE
C HERE JUST ANOTHER CHARACTER TO MOVE, DO THE MOVE.
    LWRK(INWRK)=LIN(INLIN)
    IF(INLIN.LT.LENGTH)INLIN=INLIN+1
    IF(INWRK.LT.LENGTH)INWRK=INWRK+1
1    CONTINUE
C COPY BACK OUT TO CMDLIN AFTER FIXUP
    IF(INWRK.GE.LENGTH)GOTO 3
    DO 4 N=INWRK,LENGTH
4    LWRK(N)=0
3    CONTINUE
C REPLACE COMMAND LINE WITH EDITED STRING FOR ENTRY NOW.
    DO 5 N=1,LENGTH
5    LCMD(N)=LWRK(N)
100    CONTINUE
    RETURN
    END
c -h- sign.for    Tue Sep  2 10:58:55 1986
    REAL *8 FUNCTION SIGN(VAR)
    REAL*8 VAR
C ALWAYS RETURN 1. OR -1. FOR THIS PROGRAM ... NEVER 0.
    SIGN=1.
    IF(VAR.LT.0.)SIGN=-1.
    RETURN
    END
c -h- slend.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SLEND(RETCD)
C COPYRIGHT (C) 1983, 1984 GLENN AND MARY EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *         SUBROUTINE   SLEND(RETCD)              *
C *                                                *
C **************************************************
C
C
C
C SETS VALUE OF LEND, POINTER TO LAST NON-BLANK CHARACTER
C IN LINE(80)
C
C
C
C
C RETCD VALUE       MEANING
C
C    1            NORMAL RETURN
C    2            ALL BLANKS
C
C
C
C   SLEND IS CALLED BY CALC
C
C VARIABLE    USE
C
C  BLANK      ' '
C    I        INDEXES CHARACTERS IN LINE(80).
C  LEND       UPON EXIT, POINTS TO THE LAST NON-
C             BLANK IN LINE(80).
C  LINE(80)   HOLDS COMMAND LINE.
C  RETCD      RETURN CODE.  1=NORMAL, 2=ALL BLANKS
C
C
C
C    SUBROUTINE SLEND(RETCD)
    InTeGer*4 LEVEL,NONBLK,LEND
    InTeGer*4 VIEWSW,BASED,RETCD
C
    CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
    CHARACTER*1 LINE(80)
C
    COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
    COMMON /CONS/ ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
C
C
C
    RETCD=1
    DO 100 I=1,80
    IF(LINE(81-I).NE.BLANK)GO TO 200
100    CONTINUE
    RETCD=2
    RETURN
200    LEND=81-I
    RETURN
    END
c -h- sscmp.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SSCMP(LINA,LINB,LENM,ICODE)
    DIMENSION LINA(1),LINB(1)
    CHARACTER*1 LINA,LINB
    ICODE=1
    DO 1 N=1,LENM
c    IF(ICHAR(LINA(N)).EQ.0.OR.ICHAR(LINB(N)).EQ.0)GOTO 2
    IF(ICHAR(LINA(N)).NE.ICHAR(LINB(N)))ICODE=0
    IF(ICODE.NE.1)GOTO 2
1    CONTINUE
2    CONTINUE
    RETURN
    END
c -h- sstr.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SSTR(CMDLIN,LA,N,LE,FORM)
    CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
    InTeGer*4 LA,N,LE
    InTeGer*4 VLEN(9),TYPE(1,1)
    CHARACTER*1 AVBLS(20,27)
    REAL*8 XVBLS(1,1),XX,VP,TMP
    COMMON/V/TYPE,AVBLS,XVBLS,VLEN
    NI=N
    N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
    LAA=N
    LEE=LE
    CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
    IF(IVLD.LE.0)GOTO 990
C    XX=XVBLS(I1,I2)
    CALL XVBLGT(I1,I2,XX)
    VP=128.D0**7
    DO 1 NN=1,8
    TMP=DINT(XX/VP)
    NBF(NN)=CHAR(IDINT(TMP))
    VP=VP/128.D0
    XX=XX-(128.D0*TMP)
1    CONTINUE
C NOW NBF HAS 8 BYTES OF DATA CORRESPONDING TO DE-HASHED
C STRING. COPY TO FORM.
    NL=NI
    DO 2 NN=1,8
    FORM(NL)=NBF(NN)
    IF(NN.GE.1)NL=NL+1
2    CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
    N=NL
    LE=LE-LSTC+NL
    DO 401 M=N,LE
    CMDLIN(M)=CMDLIN(M+LSTC-NL)
401    CONTINUE
C HOPE ALL'S WELL NOW...
    RETURN
990    FORM(N)=CMDLIN(N)
    RETURN
    END
c -h- strcmp.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
C COPYRIGHT (C) 1983 GLENN EVERHART
C ALL RIGHTS RESERVED
C 60=MAX REAL ROWS
C 301=MAX REAL COLS
C 60 MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS
C VBLS AND TYPE DIMENSIONED 60,301
C **************************************************
C *                                                *
C *   SUBROUTINE STRCMP(NAME,LENGTH,RETCD)         *
C *                                                *
C **************************************************
C
C
C  STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH)
C  THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE:
C
C    1=MATCH
C    2=FAILURE
C
C  UPON EXIT, COMMON VARIABLE NONBLK
C         IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED
C                 FOR MATCH
C         IF FAILURE, UNCHANGED
C
C
C
C  MODIFICATION CLASSES: M2
C
C
C
C  STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80)
C
C  STRCMP IS CALLED BY CMND
C
C
C
C
C VARIABLE       USE
C
C   I2        INDEXES NAME(LENGTH).
C   IS        HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS
C             AND IT IS NECESSARY TO RESTORE THE VALUE.
C   LENGTH    HOLDS THE LENGTH OF VECTOR NAME.
C   NONBLK    POINTER FOR COMMAND LINE HELD BY LINE(80).
C   RETCD     HOLDS RETURN CODE.  1=MATCH,  2=FAILURE
C
C
C
C
C    SUBROUTINE  STRCMP(NAME,LENGTH,RETCD)
    InTeGer*4 LENGTH
    InTeGer*4 LEVEL,NONBLK,LEND
    InTeGer*4  RETCD,VIEWSW,BASED
C
    CHARACTER*1  LINE(80),NAME(LENGTH)
    CHARACTER*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
C
    COMMON  /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
    COMMON  LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER
C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER
C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER
C IN THE COMMAND NAME (AFTER THE ASTERISK).
    IS=NONBLK
    CALL GETNNB(IPT,RETCD)
    GO TO (10,999),RETCD
C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME
C
C
10    DO 100 I2=1,LENGTH
    CALL GETNNB(IPT,RETCD)
    GO TO (20,999),RETCD
    STOP 20
20    NONBLK=IPT
    IF(NAME(I2).NE.LINE(NONBLK))GOTO 999
100    CONTINUE
    RETCD=1
    RETURN
C
C
C NO MATCH
999    RETCD=2
C IF ERROR, RESTORE VALUE OF NONBLK
    NONBLK=IS
    RETURN
    END
c -h- svbl.for    Tue Sep  2 10:58:55 1986
    SUBROUTINE SVBL(CMDLIN,LA,N,LE,FORM)
    InTeGer*4 VLEN(9),TYPE(1,1)
    CHARACTER*1 AVBLS(20,27)
    REAL*8 XVBLS(1,1)
    COMMON/V/TYPE,AVBLS,XVBLS,VLEN
    CHARACTER*1 CMDLIN(132),FORM(128),NBF(8)
    CHARACTER*3 NBF3
    EQUIVALENCE(NBF3(1:1),NBF(5))
    InTeGer*4 LA,N,LE
    NI=N
    N=N+2
C LOOK FOR V1,V2 VARIABLES; THEN GET NAME TO FILL IN.
    LAA=N
    LEE=LE
    CALL VARSCN(CMDLIN,LAA,LEE,LSTC,I1,I2,IVLD)
    IF(IVLD.LE.0)GOTO 990
    LAA=LSTC+1
C ACCEPT ANY DELIMITER
    LEE=LE
    CALL VARSCN(CMDLIN,LAA,LEE,LSTC,J1,J2,IVLD)
    IF(IVLD.LE.0)GOTO 990
C    XX=XVBLS(I1,I2)
    CALL XVBLGT(I1,I2,XX)
C XX IS COL #
C    XY=XVBLS(J1,J2)-1.0
    CALL XVBLGT(J1,J2,XY)
    IF(XX.LE..99.OR.XX.GT.DFLOAT(RRW))GOTO 990
    IF(XY.LE..99.OR.XY.GT.DFLOAT(RCL))GOTO 990
    IC=XX
    CALL IN2AS(IC,NBF)
    IR=XY
    WRITE(NBF3(1:3),300)IR
C    ENCODE(3,300,NBF(5))IR
300    FORMAT(BZ,I3)
    NL=NI
C FILL IN DECODED VARIABLE NAME, ZOTTING OUT EXTRA SPACES.
    DO 400 NN=1,7
    FORM(NL)=NBF(NN)
    IF(FORM(NL).GT.64)NL=NL+1
400    CONTINUE
C NOW ADJUST CMDLIN AND SET RETURN UP FOR ORIGINAL LENGTH FIXUP
C NOTE NI IS WHERE N WAS ON START (INDEX OF _)
C AND LSTC IS NEXT CHAR AFTER 2ND VARIABLE ON CMDLIN
C AND NL IS NEXT CHAR IN FORM. ASSUME THAT FORM IS NOW SHORTER
C AND MOVE CMDLIN DOWN.
    N=NL
    LE=LE-LSTC+NL
    DO 401 M=N,LE
    CMDLIN(M)=CMDLIN(M+LSTC-NL)
401    CONTINUE
C HOPE ALL'S WELL NOW...
    RETURN
990    CONTINUE
    FORM(N)=CMDLIN(N)
    RETURN
    END
c -h- swrt.for    Tue Sep  2 10:58:55 1986
C
C SWRT - WRITE VARIABLE LENGTH STRING TO SCREEN WITHOUT
C RECORD TERMINATION.
C COPYRIGHT GLENN C EVERHART 1984
C ALL RIGHTS RESERVED
C *** Don't use for normal Amiga stuff, but have available in case
C *** it should be handy someplace...
C
C
ccc    SUBROUTINE SWRT(STRING,LENGTH)
ccc    CHARACTER*1 STRING(127)
ccc    INTEGER LENGTH
cccC DUMP OUT ALL WE CAN..
ccc    CHARACTER*9 SFM
ccc    CHARACTER*1 SFMX(9)
ccc    CHARACTER*3 SNM
ccc    EQUIVALENCE(SNM,SFMX(2))
ccc    EQUIVALENCE (SFMX(1),SFM)
cccC HERE ARE THE BUILT IN FORMATS. NOTE WE FILL IN THE
cccC REPEAT COUNT AT RUNTIME FOR THE TEXT TO BE WRITTEN.
cccC NOTE ALSO THAT THE 1ST CHAR IS A # SIGN TO SHOW UP PROBLEMS.
cccC FORMATS ARE (nnnA1,\)
cccC COMPRISING 13 CHARACTERS IN ALL.
ccc    DATA SFM/'(001A1,\)'/
cccC NOTE WE JUST FILL IN THE LENGTH AND WRITE TO SCREEN USING
cccC SFM AS A RUNTIME FORMAT.
cccC
ccc    IF(LENGTH.LE.0)RETURN
ccc    WRITE(SNM,1)LENGTH
ccc1    FORMAT(BZ,I3)
cccC WRITE ON UNIT 6 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
cccC (VIA EXPLICIT OPEN IN MAIN PROGRAM)
ccc    WRITE(11,SFM)(STRING(II),II=1,LENGTH)
ccc    RETURN
ccc    END
    SUBROUTINE VWRT(STRING,LENGTH)
C VWRT is like SWRT but writes to lun 11 window instead.
    CHARACTER*1 STRING(127)
    INTEGER LENGTH
C DUMP OUT ALL WE CAN..
    IF(LENGTH.LE.0)RETURN
C WRITE ON UNIT 11 WHICH IS OUR SPECIALLY OPENED CONSOLE OUTPUT UNIT
C (VIA EXPLICIT OPEN IN MAIN PROGRAM)
    REWIND 11
    WRITE(11,777)(STRING(II),II=1,LENGTH)
    REWIND 11
777    format(1X,127A1)
    RETURN
    END